VBA【常用案例】

【1】工作表批量另存为独立的工作簿

Sub 工作表批量另存为独立的工作簿()

    Dim oWK As Worksheet

    Dim oWB As Workbook

    Dim sPath As String

    Dim sName As String

    If MsgBox('现在开始将把各工作表独立另存为工作簿文件，请再次检查格式数据是否正确？', vbYesNo, '重要提示') = vbYes Then

        sPath = Excel.ThisWorkbook.Path

        Excel.Application.ScreenUpdating = False

        Excel.Application.DisplayAlerts = False

        For Each oWK In Excel.ThisWorkbook.Worksheets

            With oWK

                    '将工作表名称作为工作簿的名称保存

                    sName = .Name

                    .Copy

                    Set oWB = Excel.Application.ActiveWorkbook

                    oWB.SaveAs sPath & '\' & .Name, xlOpenXMLWorkbook

                    oWB.Close

            End With

        Next

        Excel.Application.ScreenUpdating = True

        Excel.Application.DisplayAlerts = True

        MsgBox '操作结束'

    End If

End Sub

【2】插入图片批注

Sub 插入图片批注()

Dim a

a = MsgBox('使用说明：1、请确认您的图片文件存在与此文件同一目录下的名称为pic的文件夹中。2、选中要添加图片批注的单元格。')

If a = 1 Then

On Error Resume Next

Dim MR As Range

Dim Pics As String

For Each MR In Selection

  If Not IsEmpty(MR) Then

    MR.Select

    MR.AddComment

    MR.Comment.Visible = False

    MR.Comment.Text Text:=''

    MR.Comment.Shape.Fill.UserPicture PictureFile:=ActiveWorkbook.Path & '\pic\' & MR.Value & '.jpg'

End If

Next

End If

End Sub

[3]行列转换

Sub 行转列()Dim i As Long, j As Long, k As LongDim m As Long, n As LongDim arr, brr, tOn Error GoTo last t = Timer Application.ScreenUpdating = False Worksheets('【行】数据').Activate Worksheets('【行】数据').AutoFilterMode = False Worksheets('【行】数据').Rows('1:1').AutoFilter ActiveWorkbook.Worksheets('【行】数据').AutoFilter.Sort.SortFields.Add Key:=Range( _ 'A1'), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets('【行】数据').AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Worksheets('【行】数据').AutoFilterMode = False Worksheets('【列】数据').Rows('1:1048576').ClearContents i = 2 m = Worksheets('【行】数据').Cells(1, 1).CurrentRegion.Columns.Count n = WorksheetFunction.CountA(Worksheets('【行】数据').Range(Cells(1, 2), Cells(WorksheetFunction.CountA(Worksheets('【行】数据').Columns('A:A')), m))) If n <= 1048580 Then '判断是否超出excel表的行数 ReDim arr(1 To n, 1 To 2) brr = Worksheets('【行】数据').Cells(1, 1).CurrentRegion.Value For j = 2 To UBound(brr) For k = 1 To UBound(brr, 2) If Len(brr(j, k)) = 0 Then Exit For If k = 1 Then arr(i, 1) = brr(j, 1) k = k + 1 arr(i, 2) = brr(j, k) Else i = i + 1 arr(i, 1) = arr(i - 1, 1) arr(i, 2) = brr(j, k) End If Next k i = i + 1 Application.StatusBar = '正在处理数据：' & j & '行/' & k - 1 & '列' Next j Worksheets('【列】数据').Rows('1:1048576').ClearContents arr(1, 1) = Worksheets('【行】数据').Cells(1, 1).Value arr(1, 2) = Worksheets('【行】数据').Cells(1, 2).Value Worksheets('【列】数据').Cells(1, 1).Resize(i, 2) = arr Worksheets('【列】数据').Activate Application.StatusBar = '处理完成！' Erase arr Erase brr Else MsgBox '行转换成列后的数据将超出Excel表行数限制！' Exit Sub End If Application.ScreenUpdating = True MsgBox '共用时：' & Round(Timer - t, 3) & ' s'last:End Sub