VBA 案例片段合集

Posted on Edited on In , Views:

调整行高

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Macro1()
    Dim arr, rng As Range, i&
    Application.ScreenUpdating = False
    t = Timer
    arr = Range("A1").CurrentRegion
    For i = 1 To UBound(arr)
        If Rows(i).RowHeight > 10 Then
            If rng Is Nothing Then
                Set rng = Cells(i, 1)
            Else
                Set rng = Union(rng, Cells(i, 1))
        End If
    Next
    If Not rng Is Nothing Then
        rng.EntireRow.RowHeight = 10
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

释义：遍历 A 列中不为空的行，将行高设置为 10。

细节说明：

  • Application.ScreenUpdating = False，关闭视图跟随
  • t = Timer，获取当前时间（非本案例必须）
  • UBound(arr)，返回引用区域的上限值

获取行数和列数

1、方式一：

1
2
ActiveSheet.UsedRange.Rows.Count
ActiveSheet.UsedRange.Columns.Count

注意事项：该方式结果可能会大于现有数量，原因曾经删除过行（或列），而且是非整行或整列删除。该语句仍返回未删除前的值，这部分行虽然已经删除，但是也记录在内。

2、方式二：

1
2
ActiveSheet.Range("A65535").End(xlUp).Row
ActiveSheet.Range("IV1").End(xlToLeft).Column

或

1
2
ActiveSheet.[A65536].End(xlUp).Row
ActiveSheet.[IV1].End(xlToLeft).Column

注意事项：只能计算出一列（行）的最后一个单元格所在的行（列）数。本例返回 A 列最后一个单元格所占的行数。

3、方式三：

1
2
Application.CountA(ActiveSheet.Range("A:A"))
Application.CountA(ActiveSheet.Range("1:1"))

或

1
2
Application.CountA(ActiveSheet.Columns(1))
Application.CountA(ActiveSheet.Columns(1))

注意事项：只能统计一列（行）的实际使用情况，得到的不一定是最后一行（列）的位置。方式二的数值比此方式大时，说明在 A 列的数据间有空白未填写的单元格。

判断文件是否打开

1
2
3
4
5
6
7
8
9
Function isOpen(strName As String) As Boolean
    Dim w As Workbook
    For Each w In Application.Workbooks
        If w.Name = strName Then
            isOpen = True: Exit Function
        End If
    Next
    isOpen = False
End Function

清除工作表中所有无内容空行

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub 删除空行()
    '关闭视图跟随
    Application.ScreenUpdating = False
    '定义变量
    Dim sheet As Worksheet
    '最大行数
    Dim maxLineNum
    '循环变量
    Dim index As Integer
    '内容为空的最小行号
    Dim minLineNum As Integer: minLineNum = 0
    '遍历所有工作表
    For Each sheet In Sheets
        '清零
        minLineNum = 0
        '激活要操作的工作表
        sheet.Activate
        '解锁（必须要解锁工作表才能够删除行）
        sheet.Unprotect Password:=123456
        '获取最大行数
        maxLineNum = sheet.[A65536].End(xlUp).Row
        '逆序删除（删除行或列均需要逆序删除）
        For index = maxLineNum To 3 Step -1
            'B 列内容为空则判为无内容空行
            If sheet.Range("B" & Trim(Str(index))).Value = "" Then
                minLineNum = index
            End If
        Next
        If minLineNum > 0 Then
            sheet.Range(sheet.Rows(minLineNum), sheet.Rows(maxLineNum - 1)).Delete
        End If
        '执行完毕后恢复加锁状态
        sheet.Protect Password:=123456
    Next
End Sub

筛选二维数组重复元素

以二维数组为例

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Sub RemovingDuplication()
    '临时变量
    Dim indexRow, indexA, indexB As Integer
    '无重复元素动态一维数组
    Dim resultTempArray()
    ReDim resultTempArray(1 To 1)
    '筛选中间元素数组
    Dim tempArray()
    Dim tempSplit() As String
    Dim Temp As String
    '遍历二维数组每行
    For indexRow = 1 To 2
        '取第 n 行
        tempArray = Application.index(dataArray, indexRow, 0)
        '重复元素用 @ 替代
        For indexA = 1 To UBound(tempArray)
            For indexB = indexA + 1 To UBound(tempArray)
                If tempArray(indexA) = tempArray(indexB) Then tempArray(indexB) = "@"
            Next
        Next
        '分隔 tempArray，消除 @ 标记，用空白字符串代替，获得无重复元素字符串
        Temp = Replace(Join(tempArray, ","), "@", "")
        '将无重复元素字符串重新按逗号分隔
        tempSplit = Split(Temp, ",")

        For indexA = LBound(tempSplit) To UBound(tempSplit)
            '将不为空字符串的元素存入动态一维数组
            If tempSplit(indexA) <> "" Then
                resultTempArray(UBound(resultTempArray)) = tempSplit(indexA)
                ReDim Preserve resultTempArray(1 To UBound(resultTempArray) + 1)
            End If
        Next
        '清空，构建结果字符串，格式为：（序号）元素名称，间隔为空格
        Temp = ""
        For indexA = 1 To UBound(resultTempArray) - 1
            Temp = Temp + "(" + Trim(Str(indexA)) + ")" + resultTempArray(indexA)
            If indexA <> UBound(resultTempArray) - 1 Then
                Temp = Temp + " "
            End If
        Next
        '写入结果
        With Worksheets("样品数据")
            '根据下标来依次填写结果到单元格，本例共两个类别
            .Range("类别" & Trim(Str(indexRow))).Value = UBound(resultTempArray) - 1
            .Range("详细" & Trim(Str(indexRow))).Value = Temp
        End With
        '每次统计下个类别前都清空
        ReDim resultTempArray(1 To 1)
    Next
End Sub

实现将指定内容跨文件复制

将 workBook1.xlsm 所有工作表的指定区域复制到 workBook2.xlsx，更新标题，工作表名称不变，并设置打印信息。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Sub CopyRangeAcrossFile()
    '关闭视图跟随
    Application.ScreenUpdating = False
    Dim desSheet, desTitle, bottomTitle, sheet As Worksheet
    '最大行数
    Dim maxLineNum
    Set desSheet = Workbooks.Open(ThisWorkbook.Path & "\" & "workBook2.xlsx")
    For Each sheet In Sheets
        '获取第一列的长度（包含无内容空行）
        maxLineNum = WorksheetFunction.CountA(sheet.Columns(1))
        '激活要复制的工作表（重要，否则无法复制）
        sheet.Activate
        '指定复制区域
        sheet.Range("A1:M" & Trim(Str(maxLineNum))).Select
        Selection.Copy
        '激活要粘贴的工作表（注意：workBook2.xlsx 至少有一个空表，否则无法粘贴）
        desSheet.Sheets(1).Activate
        '新建工作表，名称与原工作表相同
        desSheet.Worksheets.Add().Name = sheet.Name
        '选择新工作表中要粘贴的区域
        desSheet.Sheets(sheet.Name).Range("A1").Select
        '不运算粘贴、不跳过空格、不转置
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        '更新新工作表标题
        desSheet.Sheets(sheet.Name).Range("A1").Value = "new" & sheet.Range("A1").Value
        '设置新工作表标题字体
        desSheet.Sheets(sheet.Name).Range("A1").Font.Size = 14
        '设置新工作表行高（全部行）
        desSheet.Sheets(sheet.Name).Cells.RowHeight = 28
        '独立设置新工作表标题行高
        desSheet.Sheets(sheet.Name).Rows(1).RowHeight = 50
        '设置新工作表 A 列列宽
        desSheet.Sheets(sheet.Name).Columns("A").ColumnWidth = 3
        '设置新工作表打印信息
        With desSheet.Sheets(sheet.Name).PageSetup
            '设置页面的方向。xlPortrait 纵向；xlLandscape 横向
            .Orientation = xlLandscape
            '左右页边距
            .LeftMargin = Application.InchesToPoints(1)
            .RightMargin = Application.InchesToPoints(1)
            '设置打印区域
            .PrintArea = "A1:L" & Trim(Str(maxLineNum + 4))
        End With
    Next
End Sub

使用 ReDim 实现二维动态数组

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub DynamicArray()
    Dim cellType, rowIndex, sheet As Worksheet
    '定义数组
    Dim dataArray()
    '改变大小（必须要在使用前定好基础大小，初始为 2 行 1 列）
    ReDim dataArray(1 To 2, 1 To 1)
    '遍历所有工作表
    For Each sheet In Sheets
        '遍历行
        For rowIndex = 1 To 65535
            '获取 O 列单元格的值
            cellType = sheet.Range("O" & Trim(Str(rowIndex))).Value
            '遇到内容为空的行意味着到达结尾，退出循环
            If cellType = "" Then
                Exit For
            End If
            '根据内容分类存入数组
            If cellType = "苹果" Then
                '获取当前数组的列数上限所在位置，存入
                dataArray(1, UBound(dataArray, 2)) = cellName
                '改变大小，本列增加 1 个存储位置
                ReDim Preserve dataArray(1 To 11, 1 To UBound(dataArray, 2) + 1)
            ElseIf cellType = "荔枝" Then
                dataArray(2, UBound(dataArray, 2)) = cellName
                ReDim Preserve dataArray(1 To 11, 1 To UBound(dataArray, 2) + 1)
            End If
        Next
    Next
End Sub

VBA 在工作表插入新行

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub InsertRow()
    Dim currentSheet As Worksheet
    '激活当前工作表
    Set currentSheet = ActiveSheet
    '限制不能插入行的工作表
    If currentSheet.Name = "Sheet1" Or currentSheet.Name = "Sheet2" Then
        MsgBox "该表格不允许添加行！"
        Exit Sub
    End If
    '获取当前激活工作表的最大行数（）
    Dim maxLineNum
    '对话框确定插入行数
    Dim insertNum As Integer
    insertNum = InputBox("输入要插入的行数！", "输入行数", "")
    '解锁（必须要解锁工作表才能够增加行）
    currentSheet.Unprotect Password:=123456
    '循环变量
    Dim index As Integer
    '循环，在当前激活工作表末尾插入新行
    For index = 1 To insertNum
        '获取当前激活工作表有效行数上限（不含无内容空行）
        maxLineNum = WorksheetFunction.CountA(currentSheet.Columns(1))
        currentSheet.Rows(maxLineNum).Insert shift:=xlShiftDown
    Next
    '执行完毕后恢复加锁状态
    currentSheet.Protect Password:=123456
End Sub