VBA常用注释代码

VBA常用注释代码
Sub 开启最近使用过的档案()
MsgBox "显示最近使用过的第二个文件名称，并开启它"
MsgBox Application.RecentFiles(2).Name
Application.RecentFiles(2).Open
End Sub
Sub 内存容量()
MsgBox "Excel可使用的内存大小为：" & Application.MemoryTotal MsgBox "Excel已使用的内存为：" & Application.MemoryUsed
MsgBox "Excel剩余的内存大小为：" & Application.MemoryFree End Sub
Sub 全屏幕模式()
Dim gamen As Boolean
MsgBox "将Excel的显示模式设为全屏幕"
gamen = Application.DisplayFullScreen
Application.DisplayFullScreen = True
MsgBox "回复原来的状态"
Application.DisplayFullScreen = gamen
End Sub
fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
希望能将一个TXT文件自动分割到几个SHEET里面，如果它超过65536行Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
FileName = Application.GetOpenFilename
If FileName = "" Then End
FileNum = FreeFile()
Open FileName For Input As #FileNum
Application.ScreenUpdating = False
Workbooks.Add Template:=xlWorksheet
Counter = 1
Do While Seek(FileNum) <= LOF(FileNum)
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName
Line Input #FileNum, ResultStr
If Left(ResultStr, 1) = "=" Then
ActiveCell.Value = "'" & ResultStr
Else
ActiveCell.Value = ResultStr
End If
If ActiveCell.Row = 65536 Then
ActiveWorkbook.Sheets.Add
Else
ActiveCell.Offset(1, 0).Select
End If
Counter = Counter + 1
Loop
Close
Application.StatusBar = False
如何用vba代码显示当前工作簿是只读状态还是可修改状态：MsgBox ThisWorkbook.ReadOnly
欲判断单元格中是否是#N/A如何处理.如:If Range("F" & bl & "").Value = "#N/A" Then
这样该单元格内容类型是否为字符串.不加引号报错.:
Sub bb()
Set testrng = [b1]
If IsError(testrng) Then
If testrng = CVErr(xlErrNA) Then
MsgBox "就是#N/A"
Else
MsgBox "其他错误"
End If
Else
MsgBox "没有错误"
End If
End Sub
Sub UseFileDialogOpen()
Dim lngCount As Long
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
' Display paths of each file selected
For lngCount = 1 To .SelectedItems.Count
MsgBox .SelectedItems(lngCount)
Next lngCount
End With
End Sub
从另外一个未打开的Excel文件中读取数据的函数
下面这个函数调用XLM宏从未打开的工作簿中读取数据. 注意: 该函数不能用于公式.
GetValue函数,需要以下四个变量
path: 未打开的Excel文件的路径(e.g., "d:¥test") file: 文件名(e.g., "test.xls")
sheet: 工作表的名称(e.g., "Sheet1")
ref: 引用的单元格(e.g., "C4")
Private Function GetValue(path, file, sheet, ref)
' 从未打开的Excel文件中检索数据
Dim arg As String
' 确保该文件存在
If Right(path, 1) <> "¥" Then path = path & "¥"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' 创建变量
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' 执行XLM 宏
GetValue = ExecuteExcel4Macro(arg)
End Function
使用该函数:
将该语句复制到VBA的模块中,然后,在适当的语句中调用该函数. 下面的例子显示D:¥test 下的文件test.xls 的Sheet1中的单元格”A1”的内容.
Sub TestGetValue()
p = "d:¥test"
f = "test.xls"
s = "Sheet1"
a = "A1"
MsgBox GetValue(p, f, s, a)
End Sub
下面还有一个例子.这个语句从一个未打开的文件中读取1200个数值(100行12列),并将结果填到当前工作表中.
Sub TestGetValue2()
p = "d:¥test "
f = "test.xls"
s = "Sheet1"
Application.ScreenUpdating = False
For r = 1 To 100
For c = 1 To 12
a = Cells(r, c).Address
Cells(r, c) = GetValue(p, f, s, a)
Next c
Next r
Application.ScreenUpdating = True
End Sub
说明: 如果工作簿处于隐藏状态,或者工作表是图表工作表,将会报错.
在VBA中怎么象"我的电脑中的文件夹档"一样让用户自已选择路径和文件.
选择文件：Application.GetopenFilename
选择文件夹：1、Application.FileDialog(msoFileDialogFolderPicker)
在H 列，从H3 开始，每隔3行分别输入 A 到H ！
Application.ScreenUpdating = False
Dim arr(1 To 65536, 1 To 1), i As Long
For i = 3 To 65536 Step 4
arr(i, 1) = Chr(((i - 3) ¥ 4) Mod 8 + 65)
Next
Range("h1:h65536") = arr
Application.ScreenUpdating = True
有一單元格，我設置了格式為自動換行。

現在想通過程式取得這個單元格自動換行產生的行數
Dim a As Integer, i As Integer, j As Integer, k As Integer, w As Single, t As String, tt As String
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
If ActiveCell.ColumnWidth > w Then 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
If j > a Then
k = k + 1
Exit Do
End If
End If
Loop
ActiveCell = t
Application.ScreenUpdating = True
ActiveCell.WrapText = True
MsgBox "自动换行行数为" & k
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Target.Row >= 2 Then
On Error Resume Next
[ChangColor_With].FormatConditions.Delete
= "ChangColor_With"
With [ChangColor_With].FormatConditions
.Delete
.Add xlExpression, , "TRUE"
.Item(1).Interior.ColorIndex = 35
.Item(1).Font.Bold = True
.Item(1).Font.ColorIndex = 3
'.Item(1).Font.Size = 20
'.Item(1) = "ｷsｲﾓｩ愰・
.Item(1).Font.Italic = True
.Item(1).Font.Underline = xlUnderlineStyleSingle
End With
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Target.Row >= 2 Then
On Error Resume Next
[ChangColor_With1].FormatConditions.Delete
= "ChangColor_With1"
With [ChangColor_With1].FormatConditions
.Delete
.Add xlExpression, , "TRUE"
.Item(1).Interior.ColorIndex = 24
End With
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Target.Row >= 2 Then
On Error Resume Next
[ChangColor_With2].FormatConditions.Delete
[ChangColor_With3].FormatConditions.Delete
= "ChangColor_With2"
= "ChangColor_With3"
With [ChangColor_With2].FormatConditions
.Delete
.Add xlExpression, , "TRUE"
.Item(1).Interior.ColorIndex = 24
End With
With [ChangColor_With3].FormatConditions
.Delete
.Add xlExpression, , "TRUE"
.Item(1).Interior.ColorIndex = 24
End With
End If
End Sub
工作表有加载宏，打开时自动加载菜单，是一个3级的，当加载另外的一个宏时，建立新菜单，接在前一个菜单下
For Each MenuItem1J In CommandBars(1).Controls
If MenuItem1J.Caption = A" Then GoTo 1
Next
Set MenuItem1J = CommandBars(1).Controls.Add(Type:=msoControlPopup) MenuItem1J.Caption = A"
1:
For Each MenuItem2J In MenuItem1J.Controls
If MenuItem2J.Caption = "B" Then GoTo 2
Next
Set MenuItem2J = MenuItem1J.Controls.Add(Type:=msoControlPopup)
MenuItem2J.Caption = "B"
Set MenuItem3J = MenuItem2J.Controls.Add(Type:=msoControlButton)
MenuItem3J.Caption = "B-1"
MenuItem3J.OnAction = "Macro1"
Set MenuItem3J = MenuItem2J.Controls.Add(Type:=msoControlButton) MenuItem3J.Caption = "B-2"
MenuItem3J.OnAction = "Macro1"
进度条：
Private Sub CommandButton1_Click()
Dim i, maxn, dd, ff As Integer
maxn = 100
UserForm1.Show
dd = 5
ff = 101
For i = 1 To maxn
Cells(i, 1) = maxn - Cells(i, 1).Value + 1
bel1.Width = Int(i / maxn * 218)
If bel1.Width >= 101 Then
If bel1.Width - 1 = ff Then
ff = bel1.Width
UserForm1.TextBox3.Text = CStr(Int(i / maxn * 100)) + "%"
If bel1.Width <= 124 Then
dd = dd + 1
UserForm1.TextBox3.Width = dd
' Application.Wait (Now + TimeValue("0:00:01"))
End If
End If
End If
UserForm1.TextBox2.Text = IIf(Int(i / maxn * 100) < 10, " " & CStr(Int(i / maxn * 100)) + "%", CStr(Int(i / maxn * 100)) + "%")
DoEvents
Next i
MsgBox "done"
Unload UserForm1
End Sub。