VBA常用注释代码.docx

《VBA常用注释代码.docx》由会员分享，可在线阅读，更多相关《VBA常用注释代码.docx（11页珍藏版）》请在冰豆网上搜索。

VBA常用注释代码

VBA常用注释代码

Sub开启最近使用过的档案（）

  MsgBox"显示最近使用过的第二个文件名称，并开启它"

  MsgBoxApplication.RecentFiles

（2）.Name

  Application.RecentFiles

（2）.Open

EndSub

Sub内存容量（）

  MsgBox"Excel可使用的内存大小为：

"&Application.MemoryTotal

  MsgBox"Excel已使用的内存为：

"&Application.MemoryUsed

  MsgBox"Excel剩余的内存大小为：

"&Application.MemoryFree

EndSub

Sub全屏幕模式（）

  DimgamenAsBoolean

  MsgBox"将Excel的显示模式设为全屏幕"

  gamen=Application.DisplayFullScreen

  Application.DisplayFullScreen=True

  MsgBox"回复原来的状态"

  Application.DisplayFullScreen=gamen

EndSub

fileToOpen=Application.GetOpenFilename（"TextFiles（*.txt）,*.txt"）

希望能将一个TXT文件自动分割到几个SHEET里面，如果它超过65536行

DimResultStrAsString

DimFileNameAsString

DimFileNumAsInteger

DimCounterAsDouble

  FileName=Application.GetOpenFilename

  IfFileName=""ThenEnd

  FileNum=FreeFile（）

  OpenFileNameForInputAs#FileNum

      Application.ScreenUpdating=False

      Workbooks.AddTemplate:

=xlWorksheet

      Counter=1

      DoWhileSeek（FileNum）

        Application.StatusBar="ImportingRow"&_

          Counter&"oftextfile"&FileName

        LineInput#FileNum,ResultStr

        IfLeft（ResultStr,1）="="Then

          ActiveCell.Value="'"&ResultStr

        Else

          ActiveCell.Value=ResultStr

        EndIf

        IfActiveCell.Row=65536Then

          ActiveWorkbook.Sheets.Add

        Else

          ActiveCell.Offset（1,0）.Select

        EndIf

        Counter=Counter+1

      Loop

  Close

  Application.StatusBar=False

如何用vba代码显示当前工作簿是只读状态还是可修改状态：

MsgBoxThisWorkbook.ReadOnly

欲判断单元格中是否是#N/A如何处理.如:

IfRange（"F"&bl&""）.Value="#N/A"Then

这样该单元格内容类型是否为字符串.不加引号报错.:

Subbb（）

Settestrng=[b1]

IfIsError（testrng）Then

  Iftestrng=CVErr（xlErrNA）Then

      MsgBox"就是#N/A"

  Else

      MsgBox"其他错误"

  EndIf

Else

  MsgBox"没有错误"

EndIf

EndSub

SubUseFileDialogOpen（）

  DimlngCountAsLong

  'Openthefiledialog

  WithApplication.FileDialog（msoFileDialogOpen）

      .AllowMultiSelect=True

      .Show

      'Displaypathsofeachfileselected

      ForlngCount=1To.SelectedItems.Count

        MsgBox.SelectedItems（lngCount）

      NextlngCount

  EndWith

EndSub

从另外一个未打开的Excel文件中读取数据的函数

下面这个函数调用XLM宏从未打开的工作簿中读取数据.

注意:

  该函数不能用于公式.

GetValue函数,需要以下四个变量

path:

  未打开的Excel文件的路径（e.g.,"d:

\test"）

file:

  文件名（e.g.,"test.xls"）

sheet:

工作表的名称（e.g.,"Sheet1"）

ref:

  引用的单元格（e.g.,"C4"）

PrivateFunctionGetValue（path,file,sheet,ref）

'  从未打开的Excel文件中检索数据

  DimargAsString

'  确保该文件存在

  IfRight（path,1）"\"Thenpath=path&"\"

  IfDir（path&file）=""Then

      GetValue="FileNotFound"

      ExitFunction

  EndIf

'  创建变量

  arg="'"&path&"["&file&"]"&sheet&"'!

"&_

    Range（ref）.Range（"A1"）.Address（,,xlR1C1）

'  执行XLM宏

  GetValue=ExecuteExcel4Macro（arg）

EndFunction

使用该函数:

将该语句复制到VBA的模块中,然后,在适当的语句中调用该函数.下面的例子显示D:

\test下的文件test.xls的Sheet1中的单元格”A1”的内容.

SubTestGetValue（）

  p="d:

\test"

  f="test.xls"

  s="Sheet1"

  a="A1"

  MsgBoxGetValue（p,f,s,a）

EndSub

下面还有一个例子.这个语句从一个未打开的文件中读取1200个数值（100行12列）,并将结果填到当前工作表中.

SubTestGetValue2（）

  p="d:

\test"

  f="test.xls"

  s="Sheet1"

  Application.ScreenUpdating=False

  Forr=1To100

      Forc=1To12

        a=Cells（r,c）.Address

        Cells（r,c）=GetValue（p,f,s,a）

      Nextc

  Nextr

  Application.ScreenUpdating=True

EndSub

说明:

如果工作簿处于隐藏状态,或者工作表是图表工作表,将会报错.

在VBA中怎么象"我的电脑中的文件夹档"一样让用户自已选择路径和文件.

选择文件：

Application.GetopenFilename

选择文件夹：

1、Application.FileDialog（msoFileDialogFolderPicker）

在H列，从H3开始，每隔3行分别输入A到H！

Application.ScreenUpdating=False

Dimarr（1To65536,1To1）,iAsLong

Fori=3To65536Step4

arr（i,1）=Chr（（（i-3）\4）Mod8+65）

Next

Range（"h1:

h65536"）=arr

Application.ScreenUpdating=True

有一單元格，我設置了格式為自動換行。

現在想通過程式取得這個單元格自動換行產生的行數

DimaAsInteger,iAsInteger,jAsInteger,kAsInteger,wAsSingle,tAsString,ttAsString

  t=CStr（ActiveCell）

  tt=t

  w=ActiveCell.ColumnWidth

  Application.ScreenUpdating=False

  ActiveCell.WrapText=False

  ActiveCell.ClearContents

  a=Len（tt）

  i=1

  j=0

  k=0

  Do

      ActiveCell=Left（tt,i）

      ActiveCell.Columns.AutoFit

      IfActiveCell.ColumnWidth>wThen

        ActiveCell.ColumnWidth=w

        k=k+1

        tt=Right（tt,Len（tt）-i+1）

        i=1

      Else

        ActiveCell.ColumnWidth=w

        i=i+1

        j=j+1

        Ifj>aThen

          k=k+1

          ExitDo

        EndIf

      EndIf

  Loop

  ActiveCell=t

  Application.ScreenUpdating=True

  ActiveCell.WrapText=True

  MsgBox"自动换行行数为"&k

PrivateSubWorksheet_SelectionChange（ByValTargetAsExcel.Range）

IfTarget.Row>=2Then

OnErrorResumeNext

[ChangColor_With].FormatConditions.Delete

Target.Name="ChangColor_With"

With[ChangColor_With].FormatConditions

.Delete

.AddxlExpression,,"TRUE"

.Item

（1）.Interior.ColorIndex=35

.Item

（1）.Font.Bold=True

.Item

（1）.Font.ColorIndex=3

'.Item

（1）.Font.Size=20

'.Item

（1）.Font.Name="ｷsｲﾓｩ愰・

.Item

（1）.Font.Italic=True

.Item

（1）.Font.Underline=xlUnderlineStyleSingle

EndWith

EndIf

EndSub

PrivateSubWorksheet_SelectionChange（ByValTargetAsExcel.Range）

IfTarget.Row>=2Then

OnErrorResumeNext

[ChangColor_With1].FormatConditions.Delete

Target.EntireRow.Name="ChangColor_With1"

With[ChangColor_With1].FormatConditions

.Delete

.AddxlExpression,,"TRUE"

.Item

（1）.Interior.ColorIndex=24

EndWith

EndIf

EndSub

PrivateSubWorksheet_SelectionChange（ByValTargetAsExcel.Range）

IfTarget.Row>=2Then

OnErrorResumeNext

[ChangColor_With2].FormatConditions.Delete

[ChangColor_With3].FormatConditions.Delete

Target.EntireRow.Name="ChangColor_With2"

Target.EntireColumn.Name="ChangColor_With3"

With[ChangColor_With2].FormatConditions

.Delete

.AddxlExpression,,"TRUE"

.Item

（1）.Interior.ColorIndex=24

EndWith

With[ChangColor_With3].FormatConditions

.Delete

.AddxlExpression,,"TRUE"

.Item

（1）.Interior.ColorIndex=24

EndWith

EndIf

EndSub

工作表有加载宏，打开时自动加载菜单，是一个3级的，当加载另外的一个宏时，建立新菜单，接在前一个菜单下

ForEachMenuItem1JInCommandBars

（1）.Controls

      IfMenuItem1J.Caption=A"ThenGoTo1

  Next

      SetMenuItem1J=CommandBars

（1）.Controls.Add（Type:

=msoControlPopup）

      MenuItem1J.Caption=A"

1:

  ForEachMenuItem2JInMenuItem1J.Controls

      IfMenuItem2J.Caption="B"ThenGoTo2

  Next

      SetMenuItem2J=MenuItem1J.Controls.Add（Type:

=msoControlPopup）

      MenuItem2J.Caption="B"

      SetMenuItem3J=MenuItem2J.Controls.Add（Type:

=msoControlButton）

      MenuItem3J.Caption="B-1"

      MenuItem3J.OnAction="Macro1"

      SetMenuItem3J=MenuItem2J.Controls.Add（Type:

=msoControlButton）

      MenuItem3J.Caption="B-2"

      MenuItem3J.OnAction="Macro1"

进度条：

PrivateSubCommandButton1_Click（）

Dimi,maxn,dd,ffAsInteger

maxn=100

UserForm1.Show

dd=5

ff=101

Fori=1Tomaxn

Cells（i,1）=maxn-Cells（i,1）.Value+1

UserForm1.Label1.Width=Int（i/maxn*218）

IfUserForm1.Label1.Width>=101Then

IfUserForm1.Label1.Width-1=ffThen

ff=UserForm1.Label1.Width

UserForm1.TextBox3.Text=CStr（Int（i/maxn*100））+"%"

IfUserForm1.Label1.Width

dd=dd+1

UserForm1.TextBox3.Width=dd

'Application.Wait（Now+TimeValue（"0:

00:

01"））

EndIf

EndIf

EndIf

UserForm1.TextBox2.Text=IIf（Int（i/maxn*100）

DoEvents

Nexti

MsgBox"done"

UnloadUserForm1

EndSub