VBA模块代码.docx
- 文档编号:10125666
- 上传时间:2023-02-08
- 格式:DOCX
- 页数:28
- 大小:311.12KB
VBA模块代码.docx
《VBA模块代码.docx》由会员分享,可在线阅读,更多相关《VBA模块代码.docx(28页珍藏版)》请在冰豆网上搜索。
VBA模块代码
我这儿excel2007的版本,编写的VBA程序不知道为什么在excel里保存不了,所以,我写到Word里了,
VBA打开程序如下:
打开一个excel,按alt+F11打开下面的界面
双击sheet1
在工作区编写代码就行了,
Sub***()
*****
Endsub
是固定的都得有,
我这儿只有打印版没有电子版,下面是有一些程序,你试着看看。
我介绍一下一些简单的语句,像
Dimpriceasinteger就是定义price作为整型变量,其他的也类似定义,你可以参照下面的例子。
If语句不同c语言,他必须有then,endif
对于for,得有to,next
详细的你参考例子,有c语言作为基础,学起来不能够不费力,这儿只是一小部分程序,本来是有介绍图形界面的,但是excel2007不给力,没办法。
下面一个例子:
单引号是注释。
要删除在B列中元素为0的元素所在的行,就是删去2,4,6,8,10行,程序为:
Subdele()'dele是我们自己写的,可以改。
DimaAsInteger'定义a作为整型变量
DimsAsInteger'定义s作为整型变量
Range("a1").CurrentRegion.Select'这儿我看了没太懂,我认为应该是选定区域,
s=Selection.Rows.Count'计算行数
Range("b1").Select'选定b1单元格
Fora=1Tos
IfActiveCell.Value=0Then'判断是否为零
ActiveCell.EntireRow.Delete'删除该行
Else
ActiveCell.Offset(1,0).Select'选定同列下一个单元格
EndIf
Next
EndSub
点击运行,得到:
Subifthenand()
DimunitsAsSingle
DimpriceAsInteger
Conststring1="Togetarebateyoumustbuyanaddtional"
Conststring2="pricemustequal$7.00"
price=Range("c1").Value
units=Range("c2").Value
Ifprice=7Andunits>=50Then
rebate=(price*units)*0.1
Range("a4").Value="therebateis:
$"&rebate
EndIf
Ifprice=7Andunits<50Then
Range("a4").Value=string1&50-units&"units(s)"
EndIf
Ifprice<>7Andunits>=50Then
Range("a4").Value=string2
EndIf
Ifprice=7Andunits<50Then
Range("a4").Value="youdidn'tmeetthecriteria"
EndIf
EndSub
Subwhattypeofday()
DimresponseAsString
DimquestionAsString
Dimstring1AsString,string2AsString
DimmydateAsDate
question="enterthedateintheformatmm/dd/yyy"
string1="weekday"
string2="weekend"
response=InputBox(question)
mydate=Weekday(CDate(response))
Ifmydate>=2Andmydate<=6Then
MsgBoxstring1
Else
MsgBoxstring2
EndIf
EndSub
Substructure()
Dimnum,mystr
num=1
Ifnum=1Then
mystr="numberequal1"
Debug.Printmystr
Else
mystr="numberequal2"
EndIf
EndSub
Subenterdata()
DimcellAsObject
Dimstring1AsString
OnErrorGoToveryend
string1="selectanycell"
Setcell=Application.InputBox(prompt:
=string1,Type:
=8).cell.Select
IfIsEmpty(ActiveCell)Then
MsgBox"hello"
ActiveCell.Offset(1,0).Select
Else
ActiveCell.Formula=InputBox("entertextornumber:
")
EndIf
veryend:
EndSub
Subwhatvalue()
Range("A9").Value.Select
IfActiveCell.Value=0Then
ActiveCell.Offset(0,1).Value="ZERO"
ElseIfActiveCell.Value>0Then
ActiveCell.Offset(0,1).Value="POSITIVE"
ElseIfActiveCell.Value<0Then
ActiveCell.Offset(0,1).Value="NEGATIVE"
EndIf
EndSub
SubTESTCONDITIONS()
Range("A1").Select
IfIsEmpty(ActiveCell)Then
MsgBox"THECELLISEMPTY"
Else
IfIsNumeric(ActiveCell.Value)Then
IfActiveCell.Value=0Then
ActiveCell.Offset(0,1).Value="ZERO"
ElseIfActiveCell.Value>0Then
ActiveCell.Offset(0,1).Value="POSITIVE"
ElseIfActiveCell.Value<0Then
ActiveCell.Offset(0,1).Value="NEGATIVE"
EndIf
Else
ActiveCell.Offset(0,1).Value="TEXT"
EndIf
EndIf
EndSub
SubTESTBUTTONS()
DimQUESTIONAsString
DimBTSAsInteger
DimMYTITLEAsString
DimMYBUTTONAsInteger
QUESTION="DOYOUWANTTOOPENANEWWORKBOOK?
"
BTS=vbYesNoCancel+vbQuestion+vbDefaultButton1
MYTITLE="newworkbook"
MYBUTTON=MsgBox(prompt:
=QUESTION,Buttons:
=BTS,Title:
=MYTITLE)
SelectCaseMYBUTTON
Case6
Workbooks.Add
Case7
MsgBox"youcanopenanewbookmanuallylater"
CaseElse
MsgBox"youpressedcancel"
EndSelect
EndSub
SubTESTBUTTONS()
DimQUESTIONAsString
DimBTSAsInteger
DimMYTITLEAsString
DimMYBUTTONAsInteger
QUESTION="DOYOUWANTTOOPENANEWWORKBOOK?
"
BTS=vbYesNoCancel+vbQuestion+vbDefaultButton1
MYTITLE="newworkbook"
MYBUTTON=MsgBox(prompt:
=QUESTION,Buttons:
=BTS,Title:
=MYTITLE)
SelectCaseMYBUTTON
CasevbYes
Workbooks.Add
CasevbNo
MsgBox"youcanopenanewbookmanuallylater"
CaseElse
MsgBox"youpressedcancel"
EndSelect
EndSub
Subtset1()
Range("a7").Select
DimcAsInteger
c=Range("a1").Value
SelectCasec
CaseIs<10
ActiveCell.Offset(0,1).Value="<10"
CaseIs=10
activacell.Offset(0,1).Value="10"
CaseIs>10
ActiveCell.Offset(0,1).Value=">10"
EndSelect
EndSub
Subdisplaydiscount()
DimunitssoldAsInteger
DimmydiscountAsSingle
unitssold=InputBox("enterthenumberofsoldunits")
mydiscount=getdiscount(unitssold)
MsgBoxmydiscount
EndSub
Functiongetdiscount(unitssoldAsInteger)
SelectCaseunitssold
Case1To200
getdiscount=0.05
CaseIs<=500
getdiscount=0.1
Case501To1000
getdiscount=0.15
CaseIs>1000
getdiscount=0.2
EndSelect
EndFunction
Subapplybold()
DoWhileActiveCell.Value<>""
ActiveCell.Font.Bold=True
ActiveCell.Offset(1,0).Select
Loop
EndSub
Subtenseconds()
Dimstopme
stopme=Now+TimeValue("00:
00:
10")
DoWhileNow Application.DisplayStatusBar=True Application.StatusBar=Now Loop Application.StatusBar=False EndSub Subsignin() DimsecretcodeAsString Do secretcode=InputBox("Enteryoursecretcode: ") Ifsecretcode="sp1045"Then ExitDo LoopWhilesecretcode<>"sp1045" EndSub Subapplybold2() DoUntilIsEmpty(ActiveCell) ActiveCell.Font.Bold=True ActiveCell.Offset(1,0).Select Loop EndSub Subdeleteblanksheets() DimmyrangeAsRange DimshcountAsInteger shcount=Worksheets.Count Do Worksheets(shcount).Select Setmyrange=ActiveSheet.UsedRange Ifmyrange.Address="$A$1"And_ Range("a1").Value=""Then Application.DisplayAlerts=False Worksheets(shcount).Delete Application.DisplayAlerts=True EndIf shcount=shcount-1 LoopUntilshcount=1 EndSub Subchangerheight() WhileActiveCell<>"" ActiveCell.RowHeight=28 ActiveCell.Offset(1,0).Select Wend EndSub Subdeletezerorows() DimtotalrAsInteger DimrAsInteger Range("a1").CurrentRegion.Select totalr=Selection.Rows.Count Range("b2").Select Forr=1Tototalr-1 IfActiveCell=0Then Selection.EntireRow.Delete totalr=totalr-1 Else ActiveCell.Offset(1,0).Select EndIf Nextr EndSub Subremovesheets() DimmysheetAsWorksheet Application.DisplayAlerts=False Workbooks.Add Worksheets("sheet2").Select ForEachmysheetInWorksheets ActiveWindow.SelectedSheets.Delete Nextmysheet EndSub Subissuchsheet() DimmysheetAsWorksheet DimcounterAsInteger counter=0 ForEachmysheetInWorksheets Ifmysheet.Name="sheet2"Then counter=counter+1 EndIf Nextmysheet Ifcounter=1Then MsgBox"thisworkbookcontainssheet2" Else MsgBox"sheet2wasnotfound" EndIf EndSub Subearlyexit() DimmycellAsRange ForEachmycellInRange("a1: h10") Ifmycell=""Then mycell.Value="empty" Else ExitFor EndIf Nextmycell EndSub Subcolorloop() DimmyrowAsInteger DimmycolAsInteger mycolor=0 Formyrow=1To8 Formycol=1To7 Cells(myrow,mycol).Select mycolor=mycolor+1 WithSelection.Interior .ColorIndex=mycolor .Pattern=xlSolid EndWith Nextmycol Nextmyrow EndSub 'startindexingarrayelementsat1 OptionBase1 Subfavoritecities() 'nowdeclarethearray Dimcities(6)AsString 'assignthevaluestoarrayelements cities (1)="baltimore" cities (2)="atlanta" cities(3)="boston" cities(4)="washington" cities(5)="newyork" cities(6)="trenton" 'displaythelistofcities MsgBoxcities (1)&Chr(13)&cities (2)&Chr(13)&cities(3)&Chr(13)&cities(4)&Chr(13)&cities(5)&Chr(13)&cities(6)&Chr(13) EndSub Subfavoritecities2() 'nowdeclarethearray Dimcities(6)AsString DimcityAsVariant 'assignthevaluestoarrayelements cities (1)="baltimore" cities (2)="atlanta" cities(3)="boston" cities(4)="washington" cities(5)="newyork" cities(6)="trenton" 'displaythelistofcities ForEachcityIncities MsgBoxcity Nextcity EndSub Subfavoritecities3() 'nowdeclarethearray Dimcities(6)AsString 'assignthevaluestoarrayelements cities (1)="baltimore" cities (2)="atlanta" cities(3)="boston" cities(4)="washington" cities(5)="newyork" cities(6)="trenton" hellocities() EndSub Subhello(cities()AsString) DimcounterAsInteger Forcounter=1To6 MsgBox"Hello! "&cities(counter) Next EndSub Sublotto() Constspins=6 Constminnumber=1 Constmaxnumber=51 DimtAsInteger'loopingvariableinouterloop DimiAsInteger'loopingvriableininnerloop DimmynumberAsString'stringtoholdallpicks Dimlucky(spins)AsString'arraytoholdgeneratedpicks mynumbers="" Fort=1Tospins Randomize lucky(t)=Int((maxnumber-minnumber+1)*Rnd)+minnumber Fori=1Tot-1 Iflucky(t)=lucky(i)Then lucky(t)=Int((maxnumber-minnumber+1)*Rnd)+minnumber i=0 EndIf Nexti MsgBox"luckynumberis"&lucky(t) mynumbers=mynumbers&""&lucky(t) Nextt MsgBox"luckynumbersare"&mynumbers EndSub Subexchange() DimtAsString DimrAsString Dimex(3,3)AsVariant t=Chr(9) r=Chr(13) ex(1,1)="japan" ex(1,2)="yen" ex(1,3)=128.2 ex(2,1)="mexico" ex(2,2)="peso" ex(2,3)=9.423 ex(3,1)="canada" ex(3,2)="dollar" ex(3,3)=1.567 MsgBox"country"&t&t&"currency"&t&"perus$"_ &r&r_ &ex(1,1)&t&t&ex(1,2)&t&ex(1,3)&r_ &ex(2,1)&t&t&ex(2,2)&t&ex(2,3)&r_ &ex(3,1)&t&t&ex(3,2)&t&ex(3,3),,_ "exchange" EndSub Subdynarray() DimcounterAsInteger 'declareadynamicarray Dimmyarray()AsInteger 'specifytheinitialsizeofthearray ReDimmyarray(5) Workbooks.Add 'populatemyarraywithvalues Forcounter=1To5 myarray(counter)=counter+1 ActiveCell.Offset(counter-1,0).Value=myarray(counter) Nextcounter 'changethesizofarraytohold10elements ReDimPreserv
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VBA 模块 代码