Excel 宏 VAB 编程实际工作使用记录汇总

简单复制-去重-做透视表

Sub 宏3()
Application.ScreenUpdating = False '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = False '关闭事件，防止触发事情，提高运行速度
t = Timer
'复制-去重
'Worksheets("处理结果").Range("A:C").ClearContents
Worksheets("派单明细报表").Select
Range("E:E,O:O,U:U").Select
Selection.Copy
Worksheets("处理结果").Select
Columns("A:C").Select
ActiveSheet.Paste
Application.CutCopyMode = False
irow = Range("a1").CurrentRegion.Rows.Count
ActiveSheet.Range("A1:C" & irow).RemoveDuplicates Columns:=Array(1, 2, 3), _
Header:=xlYes

 '透视表
 Worksheets("处理结果").Range("J:N").ClearContents
 'irow = Range("a1").CurrentRegion.Rows.Count '选择最大行
 'aa = Range("A1:C" & irow).Select
 'R1C1:R1048576C3
 ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    "处理结果!R1C1:R1048576C3", Version:=6).CreatePivotTable TableDestination:= _
    "处理结果!R2C10", TableName:="数据透视表2", DefaultVersion:=6
Sheets("处理结果").Select
Cells(2, 10).Select
ActiveSheet.PivotTables("数据透视表2").RepeatAllLabels xlRepeatLabels
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("数据透视表2").PivotFields("发货区域")
    .Orientation = xlRowField
    .Position = 1
End With
With ActiveSheet.PivotTables("数据透视表2").PivotFields("派单类型")
    .Orientation = xlColumnField
    .Position = 1
End With
ActiveSheet.PivotTables("数据透视表2").AddDataField ActiveSheet.PivotTables("数据透视表2" _
    ).PivotFields("派单单号"), "计数项:派单单号", xlCount
ActiveWorkbook.ShowPivotTableFieldList = False

Worksheets("处理结果").Range("A:C").ClearContents
MsgBox Timer - t & "秒完成"
Application.ScreenUpdating = True '结束屏幕更新

End Sub

VBA 字典多表匹配

----------------------------------------------------------------------------------------------------------------------------------------

'三表之中sheet1、sheet2、sheet3 匹配(把sheet2合同号、sheet3合同号匹配到sheet1里面去)
Sub nihao1()
Windows("信贷数据匹配.xlsm").Activate
Worksheets("Sheet1").Select
Worksheets("Sheet2").Select
Sheets("Sheet3").Select
Dim i&, Myr&, arr, j&
Dim d, k, t, m&, Arr1
Set d = CreateObject("Scripting.Dictionary") '定义字典'
Set d2 = CreateObject("Scripting.Dictionary") '定义字典'
'Set d2 = CreateObject("Scripting.Dictionary") '定义字典'
'Set d3 = CreateObject("Scripting.Dictionary") '定义字典'
'Set d4 = CreateObject("Scripting.Dictionary") '定义字典'
'Set d5 = CreateObject("Scripting.Dictionary") '定义字典'
'y = d(Arr(Range("c1:c200"))) + 1
Worksheets("Sheet3").Select '开始运行字典'
With Sheets("Sheet3")
X = Range("b1").CurrentRegion.Rows.Count '设置最大行'
For i = 2 To X
d(.Cells(i, 2).Value) = .Cells(i, 2).Value
'd2(.Cells(i, 2).Value) = .Cells(i, 2).Value
' d2(.Cells(i, 2).Value) = .Cells(i, 7).Value
' d3(.Cells(i, 2).Value) = .Cells(i, 8).Value
' d4(.Cells(i, 2).Value) = .Cells(i, 9).Value
' d5(.Cells(i, 2).Value) = .Cells(i, 10).Value
'd1(.Cells(i, 1).Value) = .Cells(i, 3).Value
Next i
End With

Worksheets("Sheet2").Select '开始运行字典'
With Sheets("Sheet2")
X1 = Range("b1").CurrentRegion.Rows.Count '设置最大行'
For i1 = 2 To X1
d2(.Cells(i1, 2).Value) = .Cells(i1, 2).Value
'd1(.Cells(i, 2).Value) = .Cells(i, 2).Value
' d2(.Cells(i, 2).Value) = .Cells(i, 7).Value
' d3(.Cells(i, 2).Value) = .Cells(i, 8).Value
' d4(.Cells(i, 2).Value) = .Cells(i, 9).Value
' d5(.Cells(i, 2).Value) = .Cells(i, 10).Value
'd1(.Cells(i, 1).Value) = .Cells(i, 3).Value
Next i1
End With

Sheets("Sheet1").Select
With Sheets("Sheet1")
y = Range("b1").CurrentRegion.Rows.Count '设置最大行'
For Z = 2 To y
.Cells(Z, 4).Value = d(.Cells(Z, 1).Value)
.Cells(Z, 3).Value = d2(.Cells(Z, 1).Value)
' .Cells(Z, 23).Value = d3(.Cells(Z, 2).Value)
' .Cells(Z, 24).Value = d4(.Cells(Z, 2).Value)
' .Cells(Z, 25).Value = d5(.Cells(Z, 2).Value)
'.Cells(Z, 21).Value = d1(.Cells(Z, 1).Value)
Next Z

End With

End Sub

（1.1）VBA批量打开桌面文件夹里面多个工作簿 -------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub test()
Dim mypath, myfile '定义
mypath = "C:\Users\xn084037\Desktop" & "\nihao" '指定路径nihao文件夹名
myfile = Dir(mypath & "*.xlsx") '指定文件家里面的工作簿(文件夹下面有多个工作簿)
Application.ScreenUpdating = False '关闭屏幕更新
Application.DisplayAlerts = False '关闭提示框
Do While myfile <> ""
If myfile <> ThisWorkbook.Name Then
Workbooks.Open mypath & myfile

'With ActiveWorkbook '批量操作的语句
'.Sheets(1).Range("A1") = "金额"
'.Sheets(2).Delete
'End With
'ActiveWorkbook.Save
'ActiveWorkbook.Close
End If
myfile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True

（1.2）VBA批量打开桌面文件夹里面多个工作簿并且把数据复制到汇总表

Sub test1()
t = Timer
p = "C:\Users\xn084037\Desktop" & "\同一个文件夹不同工作簿分案清单合并VBA" '指定文件路径
f = Dir(p & "*.xlsx") '指定文件夹旗下多个工作簿
Application.ScreenUpdating = False '关闭屏幕显示
ReDim brr(1 To 100000, 1 To 26) '定义汇总表数组范围
Do While f <> ""
If f <> ThisWorkbook.Name Then
n = n + 1 '文件夹里面工作簿个数
Set sh = GetObject(p & f).Sheets(1) '打开这些文件夹旗下所有工作簿的一个sheets
Arr = sh.[a1].CurrentRegion '定义Arr数据范围为每个sheets的a1单元格不为空区域
Workbooks(f).Close False
For i = 2 To UBound(Arr) '子表中行的取值范围
m = m + 1 '汇总表中第一行为表头,第一次循环时，汇总表中为2行才是填充数据，所以m=m+1就是汇总表中的步长，
'brr(m, 1) = Arr(i, 4)
For j = 1 To 26 '列的取值范围
brr(m, j) = Arr(i, j) 'brr(m, j)是汇总表数组，Arr(i, j)是子表数组
Next
Next
End If
f = Dir
Loop
Set sh = Nothing '释放内存
If m > 0 Then
[a1].CurrentRegion.Offset(1).ClearContents '可以在保留第一行表头的情况下，把其他行的数据都彻底删除。
[a2].Resize(m, 26) = brr
End If
Application.ScreenUpdating = True
MsgBox "合并了：" & n & "个文件；共有：" & m & "行数据。" & "用时：" & Format(Timer - t, "0.00") & "秒" '显示
End Sub

（1）执行打开已隐藏辅助表功能

Sub chuxian() '执行打开已隐藏辅助表功能
Worksheets("总回退").Visible = True
Worksheets("总回退辅表").Visible = True
Worksheets("总回收率").Visible = True
Worksheets("总回收率辅表").Visible = True
Worksheets("跑出的数据").Visible = True
Worksheets("批量添加").Visible = True
Worksheets("M3回收率").Visible = True
Worksheets("M3").Visible = True
Worksheets("M2_1回收率").Visible = True
Worksheets("M2-1").Visible = True
Worksheets("M2_2回收率").Visible = True
Worksheets("M2-2").Visible = True
Worksheets("异常处理").Visible = True
End Sub

（2）类似于excel中sumifs函数

Sub match_caculate() '本代码主要功能是类似于excel中sumifs函数通过工号匹配可算回款数据，生成第八列员工实际回款、第9列回收率=员工实际回款/逾期金额、'第10列排名

Sheets("总回收率").Select '选择对象总回收率这个sheet(总回收率的数据先从数据库跑出来)

a = Range("a1").CurrentRegion.Rows.Count '选择最大行

For i = 2 To a ' 循环的写法
'类似于excel中sumifs函数通过工号匹配可算回款数据
Cells(i, 8) = WorksheetFunction.SumIfs(Sheets("可算回退").Range("J:J"), Sheets("可算回退").Range("B:B"), Sheets("总回收率").Range("B" & i)) '第八列员工实际回款

Cells(i, 9) = Cells(i, 8) / Cells(i, 7) '第9列回收率=员工实际回款/逾期金额

Cells(i, 10) = i - 1 '第10列排名

Next i

End Sub

（3）填充功能

Sub add_() '填充功能

Worksheets("可算回退辅表").Select '选择对象批可算回退辅表这个sheet

Range("A1") = "合同&工号" '可算回退辅表的A1单元格=合同&工号

a = Range("B1").CurrentRegion.Rows.Count '取最大行

Range("A2").FormulaR1C1 = "=RC[1]&RC[2]" 'B2列&C2列（合同&工号）

Range("A2").AutoFill Destination:=Range("A2:A" & a), Type:=xlFillDefault '填充

Worksheets("批量处理").Select '选择对象批量处理这个sheet

b = Range("B1").CurrentRegion.Rows.Count '取最大行

Range("C2").AutoFill Destination:=Range("C2:C" & b), Type:=xlFillDefault '填充

Range("D2").AutoFill Destination:=Range("D2:D" & b), Type:=xlFillDefault '填充

Range("E2").AutoFill Destination:=Range("E2:E" & b), Type:=xlFillDefault '填充

Range("F2").AutoFill Destination:=Range("F2:F" & b), Type:=xlFillDefault '填充

Range("G2").AutoFill Destination:=Range("G2:G" & b), Type:=xlFillDefault '填充

Range("H2").AutoFill Destination:=Range("H2:H" & b), Type:=xlFillDefault '填充

Range("J2").AutoFill Destination:=Range("J2:J" & b), Type:=xlFillDefault '填充

Range("K2").AutoFill Destination:=Range("K2:K" & b), Type:=xlFillDefault '填充

Range("M2").AutoFill Destination:=Range("M2:M" & b), Type:=xlFillDefault '填充

Range("N2").AutoFill Destination:=Range("N2:N" & b), Type:=xlFillDefault '填充

End Sub

（4）主要执行xindai 表清空、筛选、选择最大行、复制、粘贴、排序、排名、循环、日期格式、调整百分比、隐藏各个辅助表功能

Sub Seperate() '主要执行xindai 表清空、筛选、选择最大行、复制、粘贴、排序、排名、循环、日期格式、调整百分比、隐藏各个辅助表功能

' ps = "是"
'
' msg = Application.InputBox(prompt:="请问是否处理了异常数据调整表的异常及回收率表的pick_me", Type:=1 + 2)
' If msg <> ps Then MsgBox "请先处理异常数据调整表的异常": Exit Sub

T = Timer '定义时间

'Call toushibiao

' If Worksheets("总回收率").Range("N4").Value = False Then
' MsgBox ("数据存在异常，请核实"): Exit Sub
' ElseIf Worksheets("总回收率").Range("N4").Value = True Then
' MsgBox ("数据无误，继续执行")
' End If

' msg = Application.InputBox(prompt:="是否需要剔除委案", Type:=1 + 2)
' If msg = ps Then
' Call 剔除委案
' End If

'清空区域

Worksheets("M1回收率").Columns("A:L").ClearContents '清空代码

Worksheets("M2回收率").Columns("A:L").ClearContents '清空代码

Worksheets("M1回退").UsedRange.ClearContents '清空代码

Worksheets("M2回退").UsedRange.ClearContents '清空代码

Worksheets("可算回退辅表").Columns("B:O").ClearContents '清空代码

'Sheets("可算回退").UsedRange.EntireColumn.AutoFit

'复制数据至辅表

Worksheets("可算回退").Select ' 选择对象可算回退这个sheet

Columns("A:J").Copy '复制可算回退A-J列

Worksheets("可算回退辅表").Select ' 选择对象可算回退辅表这个sheet

Worksheets("可算回退辅表").Range("B1").Select '选择对象可算回退辅表这个sheet的B1

     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False '执行粘贴代码

'Columns("C:C").Insert Shift:=xlToRight

Columns("F:F").Select '选择对象F列

Selection.NumberFormatLocal = "yyyy/mm/dd" '把F列的日期格式设置为年月日（yyyy/mm/dd）

Columns("J:J").Select '选择对象J列

Selection.NumberFormatLocal = "yyyy/mm/dd" '把J列的日期格式设置为年月日（yyyy/mm/dd）

'复制数据至各子表

'表1

Worksheets("可算回退辅表").Select ' 选择对象可算回退辅表这个sheet

a = Range("A1").CurrentRegion.Rows.Count '选择最大行

Set edg = Worksheets("可算回退辅表").UsedRange

ActiveSheet.Range("B1:O1").AutoFilter field:=4, Criteria1:="M1" '筛选第四列=M1数据

edg.Copy '复制

Worksheets("M1回退").Select '选择对象M1回退这个sheet

Worksheets("M1回退").Range("A1").Select '选择对象M1回退这个sheet的A1列

ActiveSheet.Paste '执行粘贴

Application.CutCopyMode = False

'表2

Worksheets("可算回退辅表").Select ' 选择对象可算回退辅表这个sheet

ActiveSheet.Range("B1:O1").AutoFilter field:=4, Criteria1:="M2" '筛选第四列=M2数据

edg.Copy '执行复制

Worksheets("M2回退").Select '选择对象M2回退这个sheet

Worksheets("M2回退").Range("A1").Select '选择对象M2回退这个sheet的A1列

ActiveSheet.Paste '执行粘贴

Application.CutCopyMode = False

Worksheets("可算回退辅表").Select ' 选择对象可算回退辅表这个sheet

Worksheets("可算回退辅表").Range("A1:M1").AutoFilter

'总回收率调整格式

Worksheets("总回收率").Select '选择对象总回收率这个sheet

x = Range("A1").CurrentRegion.Rows.Count '选择最大行

Dim rng As Range '定义 rng As Range

Set rng = Range("A1:J" & x) '选定范围

rng.Sort key1:="员工实际回款", order1:=xlDescending, Header:=xlYes '对员工实际回款这列进行降序排序

For i = 2 To x

Range("J" & i) = i - 1 '对J列排名

Range("H2:H" & x).Select '选择 H2所在列

Selection.NumberFormatLocal = "G/通用格式" '调整格式

Range("I2:I" & x).Select '选择I2所在列

Selection.NumberFormatLocal = "0.00%" '调整百分比为2位小数点

'总回收率的数据拆分至各子表
'表1

Worksheets("总回收率").Select '选择对象总回收率这个sheet

Range("A1:J" & x).AutoFilter field:=4, Criteria1:="M1" '筛选第四列=M1数据

rng.Copy '执行复制

Worksheets("M1回收率").Select '选择对象M1回收率这个sheet

Worksheets("M1回收率").Range("A1").Select '选择对象M1回收率这个sheet的A1列

ActiveSheet.Paste '执行粘贴代码

Y = Range("A1").CurrentRegion.Rows.Count '选择最大行

For i = 2 To Y '循环

Range("J" & i) = i - 1 '对J列排名

Application.CutCopyMode = False

'表2

Worksheets("总回收率").Select '选择对象总回收率这个sheet

Range("A1:J" & x).AutoFilter field:=4, Criteria1:="M2" '筛选第四列=M2数据

rng.Copy '执行复制代码

Worksheets("M2回收率").Select '选择对象M2回收率这个sheet

Worksheets("M2回收率").Range("A1").Select '选择对象M2回收率这个sheet的A1列

ActiveSheet.Paste '执行粘贴

Y = Range("A1").CurrentRegion.Rows.Count '选择最大行

For i = 2 To Y '循环

Range("K" & i) = i - 1 'K列排名

Application.CutCopyMode = False

Worksheets("总回收率").Range("a1:j1").AutoFilter

MsgBox Timer - T & "秒完成嘿嘿" '程序执行后提示完成时间

Set rng = Nothing '释放 rng

Set edg = Nothing '释放 edg

'以下代码是隐藏各个辅助表
Worksheets("可算回退").Visible = False

Worksheets("可算回退辅表").Visible = False

Worksheets("总回收率").Visible = False

Worksheets("M2回退").Visible = False

Worksheets("M2回收率").Visible = False

Worksheets("跑出后的数据").Visible = False

Worksheets("批量处理").Visible = False