基于VBA编程实现一键操作线下自动分单实战工作案例

1--------------------------- 临时清除1
Sub 临时清除1() '单合同
'Windows("随机分案模型").Activate
'p = Range("E1").CurrentRegion.Rows.Count '选择最大行
Windows("分期M2分案清单.xlsm").Activate
Worksheets("分期M2模型").Range("a2:a50000").ClearContents
Worksheets("分期M2模型").Range("E2:E50000").ClearContents
End Sub
2------------------------------拆分为单合同1
Sub 拆分为单合同1()
Worksheets("colletion库导出31天以上合同已剔除正常结清状态").Select ' 选择对象可算回退辅表这个sheet
A = Range("A1").CurrentRegion.Rows.Count '选择最大行
Range("A2:AR" & A).Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("A1:AR" & A).AutoFilter Field:=44, Criteria1:="单合同" '筛选第四列=M1数据
Worksheets("colletion库导出31天以上合同已剔除正常结清状态").Range("A2:AR" & A).Copy '复制
Selection.Copy
Worksheets("单合同清单").Select '选择对象M1回退这个sheet
Worksheets("单合同清单").Range("A2").Select '选择对象M1回退这个sheet的A1列
ActiveSheet.Paste '执行粘贴
Application.CutCopyMode = False
Worksheets("colletion库导出31天以上合同已剔除正常结清状态").Select
ActiveSheet.Range("1:1").AutoFilter Field:=44
End Sub

3-------------------------------分期M2单合同数据预处理1
Windows("分期M2分案清单.xlsm").Activate '指定工作簿
Worksheets("单合同清单").Select
aa = Range("a1").CurrentRegion.Rows.Count '选择最大行
Range("A2:AW2" & aa).ClearContents
Sub 分期M2单合同数据预处理1() '单合同
Application.ScreenUpdating = False '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = False '关闭事件，防止触发事情，提高运行速度
'复制
Windows("分期M2分案清单.xlsm").Activate '指定工作簿
Worksheets("单合同清单").Select
' aa = Range("a1").CurrentRegion.Rows.Count
' Worksheets("单合同清单").Range("A2:AW2" & aa).ClearContents '每次执行前清空表格
'
'增加B列
Columns("C:C").Select '指定区域
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Selection.NumberFormatLocal = "@"
Range("C1") = "合同号"
'要匹配业务反馈待剔除合同

Windows("分期M2分案清单").Activate
Worksheets("单合同清单").Select
Dim i&, Myr&, arr, j&
Dim d, k, t, m&, Arr1
Set d = CreateObject("Scripting.Dictionary") '定义字典'
Set d1 = CreateObject("Scripting.Dictionary") '定义字典'
'y = d(Arr(Range("c1:c200"))) + 1
Worksheets("委外要留案名单").Select '开始运行字典'
With Sheets("委外要留案名单")
X = Range("a1").CurrentRegion.Rows.Count '设置最大行'
    For i = 2 To X
         d(.Cells(i, 2).Value) = .Cells(i, 2).Value
         'd1(.Cells(i, 1).Value) = .Cells(i, 3).Value
     Next i
End With
Sheets("单合同清单").Select
With Sheets("单合同清单")
y = Range("a1").CurrentRegion.Rows.Count  '设置最大行'
    For Z = 2 To y
        .Cells(Z, 3).Value = d(.Cells(Z, 2).Value)
        '.Cells(Z, 21).Value = d1(.Cells(Z, 1).Value)
    Next Z
End With
    

'删除特定的行(剔除掉分案清单中合同号能匹配上要匹配业务反馈待剔除合同)

For i = Sheets("单合同清单").Cells(200000, 1).End(xlUp).Row To 2 Step -1

If Cells(i, 2) = Cells(i, 3) Then

Rows(i).Delete

End If

Next i

'在去掉合同后缀字母a并赋值在B列
 Sheets("单合同清单").Select
 aa = Range("a1").CurrentRegion.Rows.Count
 For i = 2 To aa
  Cells(i, 3) = Left(Cells(i, 2), Len(Cells(i, 2)) - 1)
  Next i

  '删除B列
Sheets("单合同清单").Select
Range("B1:B" & aa).Select
Selection.Delete shift:=xlToLeft

'RAND()增加随机列及去公式化操作
'产生随机列()
Sheets("单合同清单").Select
aa = Range("A1").CurrentRegion.Rows.Count
For i = 2 To aa
     Cells(i, 45) = Rnd
 Next i

'增加随机列升序排序
Sheets("单合同清单").Select
Dim rng As Range
aa = Range("a1").CurrentRegion.Rows.Count '选择最大行
Set rng = Range("A1:AS" & aa)
rng.Sort key1:="增加随机列", order1:=xlAscending, Header:=xlYes


 '逾期天数升序排序
 Dim rng1 As Range
 Set rng1 = Range("A1:AS" & aa)
 rng1.Sort key1:="逾期天数", order1:=xlAscending, Header:=xlYes


'待收余额升序排序
Dim rng2 As Range
Set rng2 = Range("A1:AS" & aa)
rng2.Sort key1:="待收余额", order1:=xlAscending, Header:=xlYes

Application.ScreenUpdating = True '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = True '关闭事件，防止触发事情，提高运行速度

End Sub
4------------------------------------ 单合同数据预处理1
Sub 单合同数据预处理1()
拆分为单合同1
'拆分为多合同1
分期M2单合同数据预处理1
End Sub
5-------------------------------------------复制催收员名单到模型表1
Sub 复制催收员名单到模型表1() '单合同
Sheets("分期M2模型").Select
aaaa = Range("a1").CurrentRegion.Rows.Count
Sheets("分期M2模型").Range("A2:A" & aaaa).ClearContents
Sheets("分期分案名单").Select
am = Range("b1").CurrentRegion.Rows.Count '最大行
Range("B2:B" & am).Select
Selection.Copy
Sheets("分期M2模型").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Sub con11() '员工人数
Worksheets("分期M2模型").Select
Range("D1").ClearContents
am = Range("a1").CurrentRegion.Rows.Count '最大行
Cells(1, 4) = Application.WorksheetFunction.CountA(Range("a2:a" & am)) '执行counta函数（统计文本个数）

End Sub
6--------------------------------------------统计员工人数及待催合同量1
Sub con22() '待催合同量
Worksheets("分期M2模型").Range("G1").ClearContents
Windows("分期M2分案清单.xlsm").Activate
Worksheets("单合同清单").Select
BB = Range("b1").CurrentRegion.Rows.Count
Worksheets("分期M2模型").Cells(1, 7) = Application.WorksheetFunction.CountA(Range("b2:b" & BB)) '执行counta函数（统计文本个数）
End Sub
Sub 统计员工人数及待催合同量1() '单合同
con11
con22
Worksheets("分期M2模型").Select
Range("g1").Select
End Sub
7--------------------------------------------整数循环1
Sub 整数循环1() '单合同
'Windows("随机分案模型.xlsm").Activate
'p = Range("E1").CurrentRegion.Rows.Count '选择最大行
Windows("分期M2分案清单.xlsm").Activate '指定工作簿
Worksheets("分期M2模型").Range("E2:E50000").ClearContents '执行之前先清除指定区域
n = Range("d1").Value
m = Range("d2").Value
Dim arr()
ReDim arr(1 To n)
For i = 2 To n + 1
arr(i - 1) = Range("a" & i).Value
Next i
For i = 1 To m
Range("e1000000").End(xlUp).Offset(1, 0).Resize(n, 1) = WorksheetFunction.Transpose(arr)
Next i
End Sub
8-------------------------------------------尾数循环
Sub 尾数循环1()
'Windows("随机分案模型").Activate
Windows("分期M2分案清单.xlsm").Activate '指定工作簿
Worksheets("分期M2模型").Select '指定工作表
EE = Range("E1").CurrentRegion.Rows.Count '选择最大行
aa = Range("A1").CurrentRegion.Rows.Count '选择最大行
b = Range("g3")
If b >= 1 Then
Range("A2:A" & b + 1).Select
Selection.Copy
Range("E" & EE + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("h1").Select
End If
End Sub
9----------------------------------------------Sub 匹配分好专员信息到对应金额表1
Application.ScreenUpdating = False '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = False '关闭事件，防止触发事情，提高运行速度
Worksheets("单合同清单").Select
aa = Range("a1").CurrentRegion.Rows.Count
Worksheets("单合同清单").Range("AT2:AW2" & aa).ClearContents '每次执行前清空表格
Worksheets("分期M2模型").Select
aaa = Range("E1").CurrentRegion.Rows.Count
Range("E2:E" & aaa).Select
'Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.SmallScroll Down:=3
Sheets("单合同清单").Select
ActiveWindow.SmallScroll Down:=-9
Range("AT2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows("分期M2分案清单").Activate
Worksheets("单合同清单").Select
Dim i&, Myr&, arr, j&
Dim d3, d4, d5, k, t, m&, Arr1
Set d3 = CreateObject("Scripting.Dictionary") '定义字典'
Set d4 = CreateObject("Scripting.Dictionary") '定义字典'
Set d5 = CreateObject("Scripting.Dictionary") '定义字典'
'y = d(Arr(Range("c1:c200"))) + 1
Worksheets("分期分案名单").Select '开始运行字典'
With Sheets("分期分案名单")
X = Range("a1").CurrentRegion.Rows.Count '设置最大行'
    For i = 2 To X
          d3(.Cells(i, 2).Value) = .Cells(i, 3).Value
           d4(.Cells(i, 2).Value) = .Cells(i, 4).Value
            d5(.Cells(i, 2).Value) = .Cells(i, 5).Value
         'd1(.Cells(i, 1).Value) = .Cells(i, 3).Value
     Next i
End With
Sheets("单合同清单").Select
With Sheets("单合同清单")
y = Range("a1").CurrentRegion.Rows.Count  '设置最大行'
    For Z = 2 To y
        .Cells(Z, 47).Value = d3(.Cells(Z, 46).Value)
        .Cells(Z, 48).Value = d4(.Cells(Z, 46).Value)
        .Cells(Z, 49).Value = d5(.Cells(Z, 46).Value)
        '.Cells(Z, 21).Value = d1(.Cells(Z, 1).Value)
    Next Z
End With

  
'设置B合同号列颜色为黄色
Sheets("单合同清单").Select
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With


'设置K待收余额列颜色为黄色
Sheets("单合同清单").Select
Range("K2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

'给S2及T2两列设置黄色
Sheets("单合同清单").Select
Range("S2:T2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

 '给AT2及AW2两列设置黄色
Sheets("单合同清单").Select
Range("AT2:AW2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
Application.ScreenUpdating = True '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = True '关闭事件，防止触发事情，提高运行速度

End Sub
10---------------------------------------------简单透视
Sub 简单透视1()
Application.ScreenUpdating = False '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = False '关闭事件，防止触发事情，提高运行速度
Worksheets("简单透视").Range("a2:D500").ClearContents '执行只先清除
Sheets("分期分案名单").Select
aa = Range("a1").CurrentRegion.Rows.Count
Range("B2:C2" & aa).Select
Selection.Copy
Sheets("简单透视").Select
Row = Range("b1").CurrentRegion.Rows.Count
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C2").Select
Application.CutCopyMode = False
Worksheets("单合同清单").Select
ab = Range("a1").CurrentRegion.Rows.Count
Sheets("简单透视").Select
Row = Range("a1").CurrentRegion.Rows.Count
For i = 2 To Row

 Cells(i, 3) = WorksheetFunction.CountIf(Worksheets("单合同清单").Range("AT2:AT" & ab), Worksheets("简单透视").Range("a" & i))
 Next i

' ActiveCell.FormulaR1C1 = "=COUNTIF(单合同清单!C[46],简单透视!RC[-1])" 'countif函数
' Range("C2").AutoFill Destination:=Range("C2:C" & aa), Type:=xlFillDefault '填充
For i = 2 To Row
Cells(i, 4) = WorksheetFunction.SumIf(Worksheets("单合同清单").Range("AT2:AT" & ab), Worksheets("简单透视").Range("a" & i), Worksheets("单合同清单").Range("K2:K" & ab))
Next i

' Range("D2").Select
' ActiveCell.FormulaR1C1 = "=SUMIF(单合同清单!C[46],简单透视!RC[-2],单合同清单!C[11])" 'sumif函数
' Range("D2").AutoFill Destination:=Range("D2:D" & aa), Type:=xlFillDefault '填充
'复制后去掉公式化粘贴
Range("C2:D2" & aa).Select
Selection.Copy
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

'增加合计   对合同量及金额求和
Worksheets("简单透视").Select
CC = Range("a1").CurrentRegion.Rows.Count
Range("C" & CC + 1).Select
Range("C" & CC + 1) = WorksheetFunction.Sum(Sheets("简单透视").Range("C2:C" & CC))
'ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"

Range("D" & CC + 1).Select
Range("D" & CC + 1) = WorksheetFunction.Sum(Sheets("简单透视").Range("D2:D" & CC))
'ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
Range("B" & CC + 1).Select
ActiveCell.FormulaR1C1 = "合计"
Range("A1").Select
 Application.ScreenUpdating = True '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = True '关闭事件，防止触发事情，提高运行速度

End Sub
11---------------------------------------------一键刷新所有操作步骤
Sub 一键刷新所有操作步骤1() '单合同

Application.ScreenUpdating = False '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
Application.EnableEvents = False '关闭事件，防止触发事情，提高运行速度
t = Timer '定义时间
Windows("分期M2分案清单.xlsm").Activate
临时清除1
单合同数据预处理1
复制催收员名单到模型表1
统计员工人数及待催合同量1
整数循环1
尾数循环1
匹配分好专员信息到对应金额表1
简单透视1

'Worksheets("分期M2模型").Visible = Flash
'Worksheets("分期M2分案名单").Visible = Flash
MsgBox Timer - t & "秒完成嘿嘿" '程序执行后提示完成时间
Sheets("简单透视").Activate
Sheets("简单透视").Range("a1:ab1").Select
Application.EnableEvents = True '关闭事件，防止触发事情，提高运行速度
Application.ScreenUpdating = True '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度
End Sub

基于VBA编程实现一键操作线下自动分单实战工作案例

你可能感兴趣的:(基于VBA编程实现一键操作线下自动分单实战工作案例)