VBA 笔记

（一）数组相关

arr = Array("a", "b", "c") '定义一个数组

'输出数组
Function print_arr(arr)
start_index = LBound(arr) '获取数组的起始索引号
end_index = UBound(arr) '获取数组的最后一个索引号
For i = start_index To end_index
    Debug.Print (arr(i))
Next
End Function


'数组升序排列
Function sort_arr_ascending(arr)
start_index = LBound(arr)
end_index = UBound(arr)
For i = start_index To (end_index - 1)
    For j = (i + 1) To end_index
        If arr(i) > arr(j) Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
        End If
    Next
Next
sort_arr_ascending = arr '定义函数的返回值
End Function


'数组降序排列
Function sort_arr_descending(arr)
start_index = LBound(arr)
end_index = UBound(arr)
For i = start_index To (end_index - 1)
    For j = (i + 1) To end_index
        If arr(i) < arr(j) Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
        End If
    Next
Next
sort_arr_descending = arr '定义函数的返回值
End Function

 

（二）筛选、拆分表格相关

Sub 钊铌应收账龄表按部门拆分()

'获取B列的数据并存入到字典的key中，利用字典的key的唯一性的特征，获取到这列数据中不重复的值组成的一个Array数组
Dim Dic, arr
Dim i As Integer, r As Integer
Dim Str As String
r = Worksheets("应收汇总").Range("B1000").End(xlUp).Row '获取B列有数据的最大行号
'If r = 1 Then Exit Sub '如果第一列没有数据那么退出程序
Set Dic = CreateObject("scripting.dictionary") '创建字典对象
For i = 4 To r '将第一列数据添加到字典的key值中
Dic(CStr(Cells(i, 2))) = ""
Next
arr = Dic.keys '返回字典key的数组
Set Dic = Nothing '销毁对象
'Str = Join(Arr, ",") '用Join函数将数组中的内容显示为一字符串
'Debug.Print Str

Dim Arrlength
Arrlength = UBound(arr) '获取数组的最大下标
For j = 0 To Arrlength
dep = arr(j)
Worksheets("应收汇总").Range("A2:Q" & r).AutoFilter field:=2, Criteria1:=dep '表格筛选
Worksheets.Add After:=Worksheets("应收汇总") '新建工作表
ActiveSheet.Name = dep '工作表重命名
Worksheets("应收汇总").Range("A2:Q" & r).Copy Worksheets(dep).Range("A1") '表格区域复制
Worksheets(dep).Columns.AutoFit '所有列自适应列宽


Dim r2
r2 = Worksheets(dep).UsedRange.Rows.Count + 1 'UsedRange.Rows.Count用于取已使用的区域的总行数，在表格中没有空行时，通常就是取得表格有数据区域的最大行数，但有空行时就仅仅是有数据的行数了，不是最末行的行数
Worksheets(dep).Select
For k = 4 To 17
Cells(r2, k).Formula = Application.Sum(Range(Cells(3, k), Cells(r - 1, k))) 'Formula用于在单元格或区域输入公式
Next
Cells(r2, 1).Value = "合计"
Rows(r2).NumberFormat = "#,##0.00_)" '设置第r2行的数值格式为千分位保留2位小数
Next

End Sub

Sub 毛宁预算表按部门拆分()
Dim filepath
filepath = ActiveWorkbook.Path '获取当前工作簿所在的路径
Dim source_wb As Workbook
Set source_wb = ActiveWorkbook

For col = 5 To 59 Step 3
    source_wb.Worksheets("22年预算执行表").Range("A4:B100").Select '选中区域
    Selection.Copy '复制选中区域

    Dim new_wb As Workbook
    Set new_wb = Workbooks.Add '新建工作簿
    new_wb.Activate '激活（切换到）刚才新建的工作簿，通常新建时就会激活，这个代码可以去掉
    new_wb.Worksheets("sheet1").Range("A1").Select '选中区域
    ActiveSheet.Paste '向选中区域粘贴值
    
    source_wb.Activate
    source_wb.Worksheets("22年预算执行表").Range(Cells(4, col), Cells(100, col + 2)).Select
    Selection.Copy
    Dim filename
    filename = source_wb.Worksheets("22年预算执行表").Cells(4, col).Value
    
    new_wb.Activate
    new_wb.Worksheets("sheet1").Range("C1").PasteSpecial Paste:=xlPasteFormats '仅粘贴格式
    new_wb.Worksheets("sheet1").Range("C1").PasteSpecial Paste:=xlPasteValues '仅粘贴值
    
    Application.DisplayAlerts = False '关闭警告，当前路径存在同名文件时会显示询问是否覆盖的对话框，使用此代码可以不显示该对话框
    new_wb.Worksheets("sheet1").Range("A:E").EntireColumn.AutoFit '自动调整列宽
    new_wb.Worksheets("sheet1").Range("A:E").EntireColumn.ColumnWidth = 13 '设置列宽为13
    ActiveWindow.DisplayGridlines = False '隐藏网格线
    new_wb.SaveAs filename:=(filepath & "\" & filename & ".xlsx") '保存工作簿
    Application.DisplayAlerts = True '打开警告，前面关闭了警告的，程序执行完毕后再打开警告，以免出现其他异常
    new_wb.Close Savechanges:=True '关闭工作簿，关闭前先保存
    source_wb.Activate
    source_wb.Worksheets("22年预算执行表").Range("A3").Select
Next

End Sub

（三）如下这段的收获就是打印工作表，以及当字符串中含有双引号时怎么表示

Sub 凡诗生成发票签收单并打印()
Dim Dic, arr
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = ActiveSheet '获取活动工作表
r = ws1.Range("D10000").End(xlUp).Row '获取工作表D列有数据的最大行数

Set Dic = CreateObject("scripting.dictionary") '创建字典对象
For i = 2 To r '将第4列数据添加到字典的key值中,前提是A列值是专用发票
    If Cells(i, 1).Value = "专用发票" Then
        Dic(CStr(Cells(i, 4))) = ""
    End If
Next

arr = Dic.keys '返回字典key的数组
Set Dic = Nothing '销毁对象

Dim Arrlength
Arrlength = UBound(arr) '获取数组最大下标

For j = 0 To Arrlength
    com = arr(j)
    Set ws2 = ActiveWorkbook.Worksheets("签收单")
    
    If (j Mod 2) = 0 Then
        ws2.Range("B3").Value = com
        ws2.Range("C3").Value = get_billing_date(ws1, r, com)
        ws2.Range("D3").Formula = "=SUMIFS('" & ws1.Name & "'!I:I,'" & ws1.Name & "'!D:D,B3,'" & ws1.Name & "'!A:A,""专用发票"")" '当字符串中含有双引号时，通常用两个双引号表示""
        ws2.Range("A3").Value = get_billing_number(ws1, r, com)
        Debug.Print (ws2.Range("A3").Value & "," & com & "," & ws2.Range("C3").Value & "," & ws2.Range("D3").Value)
        
        '当j是偶数，又是数组中最后一个下标时，直接打印页面
        If j = Arrlength Then
            ws2.PrintOut Copies:=1   '打印工作表1份
        End If
    Else
        ws2.Range("B11").Value = com
        ws2.Range("C11").Value = get_billing_date(ws1, r, com)
        ws2.Range("D11").Formula = "=SUMIFS('" & ws1.Name & "'!I:I,'" & ws1.Name & "'!D:D,B11,'" & ws1.Name & "'!A:A,""专用发票"")" '当字符串中含有双引号时，通常用两个双引号表示""
        ws2.Range("A11").Value = get_billing_number(ws1, r, com)
        Debug.Print (ws2.Range("A11").Value & "," & com & "," & ws2.Range("C11").Value & "," & ws2.Range("D11").Value)
        
        '此处调用打印
        ws2.PrintOut Copies:=1
    End If
Next


End Sub

Function get_billing_date(work_sheet As Worksheet, max_row, com_name)

For i = 2 To max_row
    If (work_sheet.Cells(i, 4).Value = com_name) And (work_sheet.Cells(i, 1).Value = "专用发票") Then
        get_billing_date = work_sheet.Cells(i, 5).Value
    End If
Next

End Function
'获取发票号，连续的发票号使用连接号连接首尾号表示，不连续的发票号用/隔开
Function get_billing_number(work_sheet As Worksheet, max_row, com_name) As String
Dim number_arr
Dim Dic
Set Dic = CreateObject("scripting.dictionary") '创建字典对象

For i = 2 To max_row
    If (work_sheet.Cells(i, 4).Value = com_name) And (work_sheet.Cells(i, 1).Value = "专用发票") Then
        Dic(CLng(work_sheet.Cells(i, 3).Value)) = ""
    End If
Next

number_arr = Dic.keys
Set Dic = Nothing '销毁对象

'此处应加入排序算法将数组做升序排列
number_arr = sort_arr_ascending(number_arr)

end_index = UBound(number_arr)
If end_index = 0 Then
    get_billing_number = "" & number_arr(0)
ElseIf end_index = (number_arr(end_index) - number_arr(0)) Then
    get_billing_number = number_arr(0) & "-" & Right(CStr(number_arr(end_index)), 2)
Else
    temp_arr = number_arr(0) & ""
    For j = 1 To end_index
        If number_arr(j) - number_arr(j - 1) > 1 Then
            temp_arr = temp_arr & "/" & number_arr(j)
        Else
            If Mid(temp_arr, Len(temp_arr) - 2, 1) = "-" Then
                temp_arr = Left(temp_arr, Len(temp_arr) - 2)
                temp_arr = temp_arr & Right(CStr(number_arr(j)), 2)
            Else
                temp_arr = temp_arr & "-" & Right(CStr(number_arr(j)), 2)
            End If
        End If
    Next
    get_billing_number = temp_arr
End If

End Function

'数组升序排列
Function sort_arr_ascending(arr)
start_index = LBound(arr)
end_index = UBound(arr)
For i = start_index To (end_index - 1)
    For j = (i + 1) To end_index
        If arr(i) > arr(j) Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
        End If
    Next
Next

sort_arr_ascending = arr
End Function

'输出数组
Function print_arr(arr)
start_index = LBound(arr)
end_index = UBound(arr)
For i = start_index To end_index
    Debug.Print (arr(i))
Next
End Function

（四）这一段收获了大量的EXCEL格式操作

Sub 黎藜盘点表拆分并打印()

'要打印盘点表的仓库的清单
Dim arr
arr = Array("总部原材料仓", "原材料仓", "返修板仓", "成品发货仓", "样品仓-工厂", "物流中心", "待检成品发货仓", _
"研发试产仓", "不良品退货仓(生产不良退)_退供应商", "工厂良品仓", "工厂待返修仓", "产线工具仓", "品质检测周转仓", _
"品质待处理仓", "工程部维修仓", "售后支持部仓", "深圳材料仓", "生产在线仓", "样品仓-总部", "总部良品仓", _
"借货品仓", "贸易商品仓")

'全局设置，关闭的内容在程序结尾要重新打开
Application.ScreenUpdating = False '全局设置，关闭屏幕刷新以提高运行速度
Application.DisplayAlerts = False '关闭警告，当前保存文件并且路径存在同名文件时，或删除工作表时，会显示询问对话框，使用此代码可以不显示该对话框
Application.SheetsInNewWorkbook = 1 '全局设置，设置新建的工作簿只有一个工作表

Dim filepath As String, r As Long
filepath = ActiveWorkbook.Path
Dim source_wb As Workbook
Set source_wb = ActiveWorkbook
'Debug.Print (source_wb.Sheets(1).Name)
'Debug.Print (ActiveSheet.Name)
r = ActiveSheet.Range("D60000").End(xlUp).Row '从第6万行往上数，若数据超过6万行此处需要修改
'Debug.Print (r)

Dim new_wb As Workbook
Set new_wb = Workbooks.Add '新建工作簿

Dim Arrlength
Arrlength = UBound(arr)
For j = 0 To Arrlength
source_wb.Sheets(1).Range("A1:H" & r).AutoFilter field:=4, Criteria1:=arr(j) '筛选表格
If j = 0 Then
new_wb.Worksheets.Add After:=new_wb.Sheets(1) '新建工作表
Else
new_wb.Worksheets.Add After:=new_wb.Worksheets(arr(j - 1))
End If

ActiveSheet.Name = arr(j) '工作表名称以仓库命名
Range("A1:N1").Merge '合并区域
Cells(1, 1).Value = arr(j) & "存货盘点表"
Cells(1, 1).HorizontalAlignment = xlCenter '设置单元格格式，居中
'设置单元格字体格式
With Cells(1, 1).Font
.Bold = True
.Name = "微软雅黑"
.Size = 18
End With
Rows(1).RowHeight = 36 '设置行高
Cells(2, 1).Value = "发料仓库"
Cells(2, 2).Value = "物料长代码"
If arr(j) = "成品发货仓" Then
    Cells(2, 3).Value = "批次"
Else
    Cells(2, 3).Value = "抽盘"
End If

Cells(2, 4).Value = "物料名称"
Cells(2, 5).Value = "规格型号"
Cells(2, 6).Value = "单位（基本）"
If arr(j) = "深圳材料仓" Then
    Cells(2, 7).Value = "深圳材料仓账面数"
Else
    Cells(2, 7).Value = "账面数"
End If
Cells(2, 8).Value = "实盘数"
Cells(2, 9).Value = "差异数"
Cells(2, 10).Value = "备注"
Cells(2, 11).Value = "顺盘（√）/逆盘（O）"
Cells(2, 12).Value = "是否报废、毁损"
Cells(2, 13).Value = "是否呆滞物料"
If arr(j) = "总部原材料仓" Or arr(j) = "成品发货仓" Then
    Cells(2, 14).Value = "生产日期"
Else
    Cells(2, 14).Value = "从物料收发卡获取的具体长库龄"
End If
If arr(j) = "原材料仓" Then
    Cells(2, 15).Value = "仓位"
    Range("A1:O1").Merge '合并单元格
End If

Range("A2:O2").HorizontalAlignment = xlCenter '设置区域格式，居中
Range("A2:O2").WrapText = True  '设置自动换行

'复制数据
source_wb.Sheets(1).Range("D2:D" & r).Copy new_wb.Worksheets(arr(j)).Range("A3")
source_wb.Sheets(1).Range("B2:B" & r).Copy new_wb.Worksheets(arr(j)).Range("B3")
source_wb.Sheets(1).Range("E2:E" & r).Copy new_wb.Worksheets(arr(j)).Range("D3")
source_wb.Sheets(1).Range("F2:F" & r).Copy new_wb.Worksheets(arr(j)).Range("E3")
source_wb.Sheets(1).Range("G2:G" & r).Copy new_wb.Worksheets(arr(j)).Range("F3")
source_wb.Sheets(1).Range("H2:H" & r).Copy new_wb.Worksheets(arr(j)).Range("G3")
If arr(j) = "成品发货仓" Then
source_wb.Sheets(1).Range("C2:C" & r).Copy new_wb.Worksheets(arr(j)).Range("C3")
End If

r1 = new_wb.Worksheets(arr(j)).Range("A60000").End(xlUp).Row '获取A列有数据区域的最大行号
Cells(r1 + 10, 1).Value = arr(j)
Cells(r1 + 10, 5).Value = "合计"
Range("G" & (r1 + 10)).Formula = "=SUM(G3:G" & r1 & ")"
Range("G" & (r1 + 10)).NumberFormatLocal = Range("G3").NumberFormatLocal '引用其他单元格的数值格式
Cells(r1 + 12, 3).Value = "盘点人："
Cells(r1 + 12, 8).Value = "监盘人："
Cells(r1 + 13, 3).Value = "日期："
Cells(r1 + 13, 8).Value = "日期："

'在第一列加入序号
ActiveSheet.Columns("A").Insert  '在A列左侧插入列
r2 = Range("Z2").End(xlToLeft).Column   '获取第2行有数据区域的最大列数
Range(Cells(1, 1), Cells(1, r2)).Merge  '合并区域
Cells(2, 1).Value = "序号"
'填充序号
For k = 3 To r1
    Cells(k, 1) = k - 2
Next

'调整边框和字体
If arr(j) = "原材料仓" Then
    Range("A1:P" & (r1 + 10)).Borders.LineStyle = 1 '设置所有框线
    Range("A" & (r1 + 10) & ":P" & (r1 + 10)).Interior.Color = RGB(166, 166, 166) '设置灰色背景
    Range("A2:P" & (r1 + 13)).Font.Name = "MS Sans Serif" '设置字体
    Range("A2:P" & (r1 + 13)).Font.Size = 9 '设置字号
Else
    Range("A1:O" & (r1 + 10)).Borders.LineStyle = 1 '设置所有框线
    Range("A" & (r1 + 10) & ":O" & (r1 + 10)).Interior.Color = RGB(166, 166, 166) '设置灰色背景
    Range("A2:O" & (r1 + 13)).Font.Name = "MS Sans Serif"
    Range("A2:O" & (r1 + 13)).Font.Size = 9
End If

'深圳材料仓加入两列
If arr(j) = "深圳材料仓" Then
    ActiveSheet.Columns("I").Insert
    ActiveSheet.Columns("I").Insert
    Cells(2, 9).Value = "售后台账账面数"
    Cells(2, 10).Value = "账面合计数"
End If

'调整列宽
r3 = Range("Z2").End(xlToLeft).Column    '获取第2行有数据区域的最大列数
For m = 1 To r3
If Cells(2, m).Value = "规格型号" Then
    Columns(m).ColumnWidth = 40  '设置列宽
ElseIf Cells(2, m).Value = "账面数" Or Cells(2, m).Value = "深圳材料仓账面数" Then
    Columns(m).ColumnWidth = 15  '设置列宽
Else
    Columns(m).AutoFit
End If
Next

'设置打印页面效果
ActiveWindow.View = xlPageBreakPreview  '切换为分页预览视图
ActiveSheet.PageSetup.Orientation = xlLandscape  '设置纸张方向为横向
ActiveSheet.PageSetup.Zoom = False '将缩放设置为false，下面的FitToPagesWide才能生效
ActiveSheet.PageSetup.FitToPagesWide = 1 '将所有列打印到一页
ActiveSheet.PageSetup.FitToPagesTall = False  '将所有行打印到N页,这两个属性要每次都一起配合使用才能生效
ActiveSheet.PageSetup.PrintTitleRows = "$1:$2" '设置打印标题行
'ActiveSheet.PageSetup.PrintTitleColumns = "$A:$D" '设置打印标题列
ActiveSheet.PageSetup.CenterFooter = "第&P页，共&N页"    '页脚添加页码
ActiveSheet.PageSetup.TopMargin = Application.CentimetersToPoints(0.5) '页面上边距
ActiveSheet.PageSetup.BottomMargin = Application.CentimetersToPoints(1) '页面下边距
ActiveSheet.PageSetup.LeftMargin = Application.CentimetersToPoints(0.5) '页面左边距
ActiveSheet.PageSetup.RightMargin = Application.CentimetersToPoints(0.5) '页面右边距
'ActiveSheet.PageSetup.HeaderMargin = Application.CentimetersToPoints(0.5) '页眉边距
ActiveSheet.PageSetup.FooterMargin = Application.CentimetersToPoints(0.5) '页脚边距
'new_wb.Worksheets(arr(j)).Columns.AutoFit
Next
new_wb.Sheets(1).Delete  '删除工作表


new_wb.SaveAs filename:=(filepath & "\" & "盘点表打印版" & ".xlsx")
'new_wb.Close Savechanges:=True
'source_wb.Activate
'source_wb.Sheets(1).Range("A1").Select

'恢复全局设置
Application.DisplayAlerts = True '打开警告，前面关闭了警告的，程序执行完毕后再打开警告，以免出现其他异常
Application.ScreenUpdating = True '程序运行完毕后重新打开屏幕刷新
End Sub

（五）当需要获取列的字母时，通常有替代方案可以满足引用的方案，比如Range(Cells(i,j), Cells(m,n))表示从i行j列，到m行n列的连续区域，或者Columns(n)表示序号为n的列，不一定要使用列字母来引用列。