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:\est") 

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:\est 下的文件test.xls 的Sheet1中的单元格”A1”的内容.

Sub TestGetValue()

    p = "d:\est"

    f = "test.xls"

    s = "Sheet1"

    a = "A1"

    MsgBox GetValue(p, f, s, a)

End Sub

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

Sub TestGetValue2()

    p = "d:\est "

    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

  Target.Name = "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).Font.Name = "ｷ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

     Target.EntireRow.Name = "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

     Target.EntireRow.Name = "ChangColor_With2"

     Target.EntireColumn.Name = "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

    UserForm1.Label1.Width = Int(i / maxn * 218)

If UserForm1.Label1.Width >= 101 Then

        If UserForm1.Label1.Width - 1 = ff Then

           ff = UserForm1.Label1.Width

           UserForm1.TextBox3.Text = CStr(Int(i / maxn * 100)) + "%"

If UserForm1.Label1.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