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列排名

Next

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列排名

Next

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列排名

Next

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

End Sub

---

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

---

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

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

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列排名

Next

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列排名

Next

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列排名

Next

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

End Sub

---

（5）值化排序 保存表格、并另存到指定位置

Sub 值化排序()'值化排序 保存表格、并另存到指定位置 功能（xiaolei）

t = Timer '对所有表格进行值化
Dim sht As Worksheet '定义 sht As Worksheet
For Each sht In Worksheets '循环体
With sht
.UsedRange.Copy '复制
.UsedRange.PasteSpecial xlPasteValues '粘贴
End With
Application.CutCopyMode = False '清空剪贴板 在复制或者剪切了大量内容后关闭文件，如果不写上这句代码，会出现提示窗口：是否保存手复制的内容到剪贴板，以便下次使用。这时文件不能自动关闭，必须手动关闭提示框才关闭文件。
Next
'Worksheets("反馈汇总").Visible = False '隐藏表格"反馈汇总明细"
Worksheets("实际回款明细表(刷)").Visible = False '隐藏表格
Worksheets("分案明细").Visible = False
Worksheets("回款明细汇总").Visible = False
Range("C3:F5").Select '选择对象数据汇总这个sheet 的C3:F5列所在区域，对区域"C3:F5"进行排序

'benyuechujiezhidaozuotiangechanpinhuishouqingkuang
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Add Key:=Range("F4:F5"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal '清空排序集合清空当前内存中Sort命令已经记录的数据，并做初始化设置
With ActiveWorkbook.Worksheets("数据汇总").Sort
.SetRange Range("C3:F5")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With '对F4:F6进行数值降序排序

'benyuexindaiM2cuishouzhuanyuanhuishouqingkuang
Range("H3:L9").Select '选择对象数据汇总这个sheet 的H3:L9列所在区域
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Add Key:=Range("L4:L9"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal '清空排序集合清空当前内存中Sort命令已经记录的数据，并做初始化设置
With ActiveWorkbook.Worksheets("数据汇总").Sort
    .SetRange Range("H3:L9")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With '对F3:F9进行数值降序排序

'benyuefenqiM2cuishouzhuanyuanhuishouqingkuang
Range("N3:R6").Select '选择对象数据汇总这个sheet 的N3:R6列所在区域
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Add Key:=Range("R4:R6"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal '清空排序集合清空当前内存中Sort命令已经记录的数据，并做初始化设置
With ActiveWorkbook.Worksheets("数据汇总").Sort
    .SetRange Range("N3:R6")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With '对N3:R6进行数值降序排序
'ActiveWindow.ScrollColumn=4表示活动窗口滚动到那一列
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Add Key:=Range("F4:F5"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("数据汇总").Sort
    .SetRange Range("C3:F5")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Range("H3:L9").Select
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Add Key:=Range("L4:L9"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("数据汇总").Sort
    .SetRange Range("H3:L9")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Range("N3:R6").Select
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("数据汇总").Sort.SortFields.Add Key:=Range("R4:R6"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("数据汇总").Sort
    .SetRange Range("N3:R6")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1

MsgBox Timer - t & "秒完成" '显示代码完成所耗的时间
End Sub

Sub 保存表格并另存到指定位置()
ThisWorkbook.Save '保存当前工作簿
tn = ThisWorkbook.Name '当前工作簿名称
tp = ThisWorkbook.Path '当前工作簿位置
tx = "E:***\10月信贷及分期M2(业绩报表)" '另存为工作簿的路径

Sheets("数据汇总").Select '选定工作表
datenum = Application.WorksheetFunction.Text(Range("A2"), "yyyymmdd") '日期（文件名后缀）

Application.DisplayAlerts = False
'ThisWorkbook.SaveAs Filename:=tp & "" & "8月信贷M2及M2+业绩报表" & "(" & datenum & ")" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False '在当前工作簿位置保存并命名
ThisWorkbook.SaveAs Filename:=tx & "" & "10月信贷及分期M2业绩报表" & "(" & datenum & ")" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False '在指定位置保存
Application.DisplayAlerts = True

End Sub
Sub 合并()
值化排序
保存表格并另存到指定位置
End Sub

---

（6）复制、分类回款明细

Sub 复制() '主要功能是把实际回款明细表(刷)数据复制粘贴到回款明细汇总
Worksheets("回款明细汇总").Range("A:C").ClearContents '清空回款明细汇总这个sheet 的A-C列数据

'信贷回款数据B:D列
Worksheets("实际回款明细表(刷)").Select '选择对象实际回款明细表(刷)
Columns("B:D").Copy '复制B到D列'
Worksheets("回款明细汇总").Select '选择对象回款明细汇总
Range("a1").Select '从a1单元格开始粘贴
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '不带格式粘贴（粘贴值）
Application.CutCopyMode = False ' 释放剪贴板内容
'rowmax = Worksheets("回款明细汇总").Range("A1").CurrentRegion.Rows.Count '选择最大行

'分期回款数据G2:I2列
rowmax = Worksheets("回款明细汇总").Range("A65536").End(xlUp).Row '选择有数据最大行
Worksheets("实际回款明细表(刷)").Select '选择对象实际回款明细表(刷)
Range("G2:I2").Select
Range(Selection, Selection.End(xlDown)).Select '复制g-i列有数据区域
Selection.Copy

'继续粘贴分期回款数据（在信贷回款数据基础上继续粘贴）
Worksheets("回款明细汇总").Select
Range("A" & (rowmax + 1)).Select '从A列有数据下一行开始粘
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

'复制粘贴字段包括催收员工号 催收员 组长 经理 type 分案日期 还款日期是否在委案日期内
irow = Worksheets("回款明细汇总").Range("A" & Cells.Rows.Count).End(xlUp).Row '有数据的最大行数，包括中间有空值的'
Worksheets("回款明细汇总").Range("D4:J4").Select '选择范围（带公式的区域）
Selection.AutoFill Destination:=Worksheets("回款明细汇总").Range("D4:J" & irow), Type:=xlFillDefault '向下填充公式至有数据的最大行
End Sub
Sub 分类回款明细() '主要功能是拆分信贷M2及分期M2对应的专员催收名单
'信贷M2
irow = Worksheets("回款明细汇总").Range("a1").CurrentRegion.Rows.Count '最大行行数
Worksheets("回款明细汇总").Range("1:" & irow).AutoFilter field:=10, Criteria1:="是" '筛选第10列，并且选择条件=是
Worksheets("回款明细汇总").Range("1:" & irow).AutoFilter field:=8, Criteria1:="信贷M2" '筛选第8列，并且选择条件=信贷M2
Worksheets("回款明细汇总").Range("A:G").Copy '执行复制
Sheets("分类回款明细【不含离职人员及手工】").Select '选择对象分类回款明细【不含离职人员及手工】
Range("B2").Select '选项对象B2列
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '非格式化粘贴(仅仅粘贴数字)
Worksheets("回款明细汇总").Rows("1:1").AutoFilter '关闭筛选'
Application.CutCopyMode = False '退出粘贴

'分期M2
Worksheets("回款明细汇总").Range("1:" & irow).AutoFilter field:=10, Criteria1:="是" '筛选第10列，并且选择条件=是
Worksheets("回款明细汇总").Range("1:" & irow).AutoFilter field:=8, Criteria1:="分期M2" '筛选第8列，并且选择条件=分期M2
Worksheets("回款明细汇总").Range("A:G").Copy '执行复制
Sheets("分类回款明细【不含离职人员及手工】").Select '选择对象分类回款明细【不含离职人员及手工】
Range("J2").Select '选项对象J2列
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '非格式化粘贴(仅仅粘贴数字)
Worksheets("回款明细汇总").Rows("1:1").AutoFilter '关闭筛选'
Application.CutCopyMode = False '退出粘贴

'Worksheets("回款明细汇总").Range("1:" & irow).AutoFilter field:=10, Criteria1:="是" '筛选第10列
'Worksheets("回款明细汇总").Range("1:" & irow).AutoFilter field:=8, Criteria1:="信贷M2+"
'Worksheets("回款明细汇总").Range("A:G").Copy
'Sheets("分类回款明细【不含手工】").Select
'Range("R2").Select
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Worksheets("回款明细汇总").Rows("1:1").AutoFilter '关闭筛选'
'Application.CutCopyMode = False '退出粘贴
End Sub
Sub 刷新()
复制
分类回款明细
End Sub

---

（7）主要执行fenqi表清空、筛选、选择最大行 、复制、粘贴、排序、排名、新 插入一列、循环判断、日期格式、自动调整列宽、调整百分比、隐藏各个辅助表功能

Sub seperate_worksheets()

Application.ScreenUpdating = False

'清空区域

Worksheets("总回收率辅表").Columns("A:K").Clear

Worksheets("M1_1回收率").Columns("A:J").ClearContents

Worksheets("M1_2回收率").Columns("A:J").ClearContents

Worksheets("M2_1回收率").Columns("A:J").ClearContents

Worksheets("M2_2回收率").Columns("A:J").ClearContents

Worksheets("M3回收率").Columns("A:J").ClearContents

Worksheets("总回退辅表").Columns("b:K").ClearContents

Worksheets("M1-1").Columns("A:K").ClearContents

Worksheets("M1-2").Columns("A:k").ClearContents

Worksheets("M2-1").Columns("A:k").ClearContents

Worksheets("M2-2").Columns("A:k").ClearContents

Worksheets("M3").Columns("A:k").ClearContents

'Call match

'If Worksheets("总回收率").Range("n3") = False Then
'MsgBox ("存在误差，请核实"): Exit Sub
'Else: MsgBox Range("N3").Value & "数据无误，继续执行"

'End If

'调整格式

Worksheets("总回收率").Select

Y = Range("A1").CurrentRegion.Rows.Count

Worksheets("总回收率").Select

Set edg = Range("A1:J" & Y)

Range("H2:H" & Y).Select

Selection.NumberFormatLocal = "0.00%"

edg.Copy

Worksheets("总回收率辅表").Select

Worksheets("总回收率辅表").Range("A1").Select

ActiveSheet.Paste

Worksheets("总回收率辅表").Select

Columns("F:F").Insert Shift:=xlToRight '在列（“F:F”）。插入移位：=xlToRight

X = Range("A1").CurrentRegion.Rows.Count '选择最多行

Range("F1") = "经理" '命名F列表头"经理"

Set rng = Range("A1:J" & X) '设置范围

For lkk = 2 To X ' 循环体

If rng(lkk, 5) = "陈新" Then '在循环体里面判断，如果在第(lkk, 5)五列任何一列的数据等于‘陈新’则，在第六列任何行对应写上刘慧
rng(lkk, 6) = "刘慧"

        ElseIf rng(lkk, 5) = "史夕阳" Then
        rng(lkk, 6) = "童超"

            ElseIf rng(lkk, 5) = "刘易新" Then
            rng(lkk, 6) = "童超"
    
                ElseIf rng(lkk, 5) = "许国朝" Then
                rng(lkk, 6) = "童超"
    
                    ElseIf rng(lkk, 5) = "严璐" Then
                    rng(lkk, 6) = "乔雨"
    
                        ElseIf rng(lkk, 5) = "费小翔" Then
                        rng(lkk, 6) = "乔雨"
    
                            ElseIf rng(lkk, 5) = "陆再婷" Then
                            rng(lkk, 6) = "刘慧"
                    
                                ElseIf rng(lkk, 5) = "尚静" Then
                                rng(lkk, 6) = "刘慧"
                    
                                    ElseIf rng(lkk, 5) = "马玉铭" Then
                                    rng(lkk, 6) = "刘慧"
                    
                                ElseIf rng(lkk, 5) = "蒋鹏" Then
                                rng(lkk, 6) = "童超"
                    
                            ElseIf rng(lkk, 5) = "李伟" Then
                            rng(lkk, 6) = "乔雨"
                                                                                
                        ElseIf rng(lkk, 5) = "张程" Then
                        rng(lkk, 6) = "乔雨"
                                                    
                    ElseIf rng(lkk, 5) = "舒阳" Then
                    rng(lkk, 6) = "乔雨"
       
                ElseIf rng(lkk, 5) = "石婷" Then
                rng(lkk, 6) = "童超"
            
            ElseIf rng(lkk, 5) = "嵇婷" Then
            rng(lkk, 6) = "乔雨"
            
        ElseIf rng(lkk, 5) = "王唯" Then
        rng(lkk, 6) = "乔雨"
            
    ElseIf rng(lkk, 5) = "冯雪" Then
    rng(lkk, 6) = "乔雨"
           
End If

Next

rng.Sort key1:="实际回款金额", order1:=xlDescending, Header:=xlYes '按实际回款金额降序排序

'循环的目的是J列排名
Worksheets("总回收率辅表").Select '选择对象

For i = 2 To X '循环体

Range("J" & i) = i - 1

Next

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

Selection.NumberFormatLocal = "G/通用格式" '设置J列格式

'回收率拆分至各子表
'表1

Worksheets("总回收率辅表").Select '选择对象

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

rng.Copy '复制

Worksheets("M1_1回收率").Select '选择对象

Worksheets("M1_1回收率").Range("A1").Select '选择对象A1

ActiveSheet.Paste '执行粘贴

Application.CutCopyMode = False '释放粘贴版

Worksheets("M1_1回收率").Select '选择对象
aaa = Worksheets("M1_1回收率").Range("A1").CurrentRegion.Rows.Count '选择最大行
'循环体最要排名
For pp = 2 To aaa

Range("J" & pp) = pp - 1

Next pp

'表2

Worksheets("总回收率辅表").Select '选择对象

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

rng.Copy '复制

Worksheets("M1_2回收率").Select '选择对象

Worksheets("M1_2回收率").Range("A1").Select '选择对象A1

ActiveSheet.Paste '执行粘贴

Application.CutCopyMode = False '释放粘贴版

Worksheets("M1_2回收率").Select '选择对象

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

'循环体最要排名
For i1 = 2 To B

Range("J" & i1) = i1 - 1

Next

'建立回退辅表

Worksheets("总回退").Select '选择对象

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

Range("G2:H" & p).Select '选择最大行G2:H的区域

Selection.NumberFormatLocal = "yyyy/mm/dd" '设置日期格式yyyy/mm/dd

Worksheets("总回退").Columns("A:J").Copy '复制选定区域

Worksheets("总回退辅表").Select '选择对象

Worksheets("总回退辅表").Range("B1").Select '选择对象B1
'不带格式粘贴
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False

'回退数据整理格式

Worksheets("总回退辅表").Select '选择对象

f = Range("B1").CurrentRegion.Rows.Count '选择最大行
   
Set rw = Range("B1:K" & f) '定义rw = Range("B1:K" & f)

Range("H2:I" & f).Select '选择最大行

Selection.NumberFormatLocal = "yyyy/m/d" '调整日期格式

'回退数据拆分至各子表

'表1

Range("B1:M" & f).AutoFilter field:=4, Criteria1:="M1-1" '筛选第四列=M1-1的数据

rw.Copy '复制

Worksheets("M1-1").Select '选择对象

Worksheets("M1-1").Range("A1").Select '选A1择对象

ActiveSheet.Paste '粘贴

Application.CutCopyMode = False '释放剪贴板

Worksheets("M1-1").Columns("A:L").EntireColumn.AutoFit '调整所有列的列宽为自动列宽
'表2

Worksheets("总回退辅表").Select '选择对象

Range("B1:M" & f).AutoFilter field:=4, Criteria1:="M1-2" '筛选第四列=M1-2的数据

rw.Copy '复制

Worksheets("M1-2").Select '选择对象

Worksheets("M1-2").Range("A1").Select '选A1择对象

ActiveSheet.Paste '粘贴

Application.CutCopyMode = False '释放剪贴板
Worksheets("M1-2").Columns("A:L").EntireColumn.AutoFit '调整所有列的列宽为自动列宽

Application.CutCopyMode = False '释放剪贴板

'释放已定义内存
Set edg = Nothing

Set rw = Nothing

Set rng = Nothing

Worksheets("总回收率辅表").Range("A1:J1").AutoFilter '自动筛选

Worksheets("总回退辅表").Range("B1:M1").AutoFilter '自动筛选

Worksheets("总回退辅表").Visible = False '隐藏附表

Worksheets("总回收率辅表").Visible = False '隐藏附表

Worksheets("总回退").Visible = False '隐藏附表

Worksheets("总回收率").Visible = False '隐藏附表

Worksheets("跑出的数据").Visible = False '隐藏附表

Worksheets("批量添加").Visible = False '隐藏附表

Worksheets("M2-1").Visible = False '隐藏附表

Worksheets("M2_1回收率").Visible = False '隐藏附表

Worksheets("M2-2").Visible = False '隐藏附表

Worksheets("M2_2回收率").Visible = False '隐藏附表

Worksheets("M3").Visible = False '隐藏附表

Worksheets("M3回收率").Visible = False '隐藏附表

Worksheets("异常处理").Visible = False '隐藏附表

Worksheets("辅助添加").Visible = False '隐藏附表

Worksheets("组长排名").Select '选择对象

Application.ScreenUpdating = True '不隐藏附表

End Sub