VBAプログラミングに基づいてワンタッチ操作ライン下自動分割実戦作業事例を実現
15253 ワード
1----------------------------------------------------------------------------------------------------------.ClearContents End Sub 2----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------.Select Application.CutCopyMode=False Selection.AutoFilter ActiveSheet.Range("A 1:AR"&A).AutoFilter Filed:=44,Criteria 1:="単一契約"'フィルタ第4列=M 1データWorksheets("colletionライブラリエクスポート31日以上の契約が正常に締結された状態").Range("A 2:AR"&A).Copy'レプリケーションSelection.Copy Worksheets("単一契約リスト").Select'選択オブジェクトM 1このsheet Worksheets("単一契約明細書").Range("A 2").Select'選択オブジェクトM 1このsheetのA 1列ActiveSheet.Paste'をロールバックしてApplication.CutCopyMode=False Worksheets(「colletionライブラリエクスポート31日以上の契約は正常な清算状態を取り除いた」).Select ActiveSheet.Range("1:1").AutoFilter Field:=44 End Sub
3--------------------------------------------------------------------------------------------------------------'シングル契約Application.ScreenUpdating=False'画面更新をオフにするとマクロの実行プロセスは見えませんが、マクロの実行速度を上げるApplication.EnableEvents=False'イベントをオフにして、トリガーを防止し、実行速度を上げる'Windowsのコピー(「分割M 2分割リスト.xlsm」).Activate'指定ワークブックWorksheets(「シングル契約リスト」).Select'aa=Range(「a 1」)CopyOrigin:=xlFormatFromLeftOrAbove
End Sub 4--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------.Selectaaa=Range("a 1").CurrentRegion.Rows.Count Sheets("分割M 2モデル").Range("A 2:A"&aaaaa).ClearContents Sheets("分割分割リスト").Selectam=Range("b 1").CurrentRegion.Rows.Count'最大行Range("B 2:B"&am).SelectSelectSelection.Copy Sheets("分割M 2モデル").SelectRange("分割M 2モデル").SelectRange("A 2’).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False,Transpose:=False End Sub Sub con 11()'従業員数Worksheets("分割M 2モデル").Select Range("D 1").ClearContents am=Range("a 1").CurrentRegion.Rows.Count'最大行Cells(1,4)=Application.WorksheetFunction.Counta(Range("a 2:a"&am))'実行counta関数(統計テキスト個数)
End Sub 6-----------------------------------------------------従業員数および催促対象契約量1 Subcon 22()'催促対象契約量Worksheets("分割M 2モデル").Range("G 1").ClearContents Windows("分割M 2分割リスト.xlsm").Activate Worksheets("単一契約リスト").Select BB=Range("b 1").CurrentRegion.Rows.Count Worksheets("分割M 2モデル").cells(1,7)=Application.WorksheetFunction.Counta(Range("b 2:b"&BB)'実行counta関数(統計テキスト個数)End Sub Sub統計従業員数および催促契約量1()'単契約con 11 con 22 Worksheets("分割M 2モデル").Select Range("g 1").Select End Sub 7-----------------------------------------------------整数サイクル1 Sub整数サイクル1()'単契約'Windows(「ランダム・シナリオモデル.xlsm」).Activate'p=Range("E 1").CurrentRegion.Rows.Clont'選択最大行Windows("分割M 2シナリオリスト.xlsm").Activate'指定ワークブックWorkshets("分割M 2モデル").Range("E 2:E 50000").ClearContents'実行前に指定領域n=Range("d 1").Value m=Range("d 2").Value Dim arr()Diarr()Diarr(()Diarr(1 Ton)For i=2 Ton+1 arr(i-1)=Range("a"&i).Value Next i Fori=1 Tom Range("e 100000").End(xlUp).Offset(1,0).Resize(n,1)=WorkshetFunction.Transpose(arr)Next i End Sub 8---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------Worksheets(「分割M 2モデル").Select'指定ワークシートEE=Range("E 1").CurrentRegion.Rows.Count'最大行aa=Range("A 1").CurrentRegion.Rows.Count'選択最大行b=Range("g 3")Ifb>=1 Then Range("A 2: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を向上させる(「シングル契約リスト」).Selectaa=Range("a 1").CourrentRegion.Rows.CountWorkshets("単一契約明細書").Range("AT 2:AW 2"&aaa).ClearContents'毎回実行前クリアテーブルWorkshets("分割M 2モデル").Selectaaa=Range("E 1").CourrentRegion.Rows.Count Range("E 2:E"&aaa).Select'Range(Selection,Selection.End(xlDown.End(xlDown.End(xlDown.End)).Select Selection.Copy ActiveWindow.SmallScroll Down:=3 Sheets("単一契約リスト").Select ActiveWindow.SmallScroll Down:=-9 Range("AT 2").Select Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone,SkipBlanks_:=False,Transpose:=False
End Sub 10---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------.ClearContents'の実行はSheets("分割リスト").Select aa=Range("a 1").CurrentRegion.Rows.Count Range("B 2:C 2"&aa).Select Selection.Copy Sheets("単純透視").Select Row=Range("b 1").CurrentRegion.Rows.Count Range("A 2")のみを先にクリアする.SelectSelection.PasteSpecial Paste:=xlPasteValues,Operation:= xlNone,SkipBlanks_:=False,Transpose:=False Range("C 2").SelectApplication.CuCopyMode=False Workshets("単一契約リスト").Selectab=Range("a 1").CurrentRegion.Rows.Cows.Cows("単純透視").SelectRow=Range("a 1").CurrentRerentRegion.Rows.Rows("単純透視").SelectRow=Range("a 1")tRegion.Rows.Count For i=2 To Row
'ActiveCell.FormulaR 1 C 1="=COUNTIF(単一契約リスト!C[46]、単純透視!RC[-1])''countif関数'Range("C 2").AutoFill Destination:=Range("C 2:C"&aa)、Type:=xlFillDefault'充填Fori=2 To Row Cells(i,4)=WorkshetFunction.SumIf(Workshets("単一契約リスト").Range("AT 2:AT"&ab)、Workshets("単純ピボット").Range("a"&i),Worksheets("単一契約明細書").Range("K 2:K"&ab))Next i
'Range("D 2").Select'ActiveCell.FormulaR 1 C 1="=SUMIF(シングル契約リスト!C[46]、単純透視!RC[-2]、シングル契約リスト!C[11])"'sumif関数'Range("D 2").AutoFill Destination:=Range("D 2:D"&aa)、Type:=xlFillDefault'充填'コピーを削除して公式化貼り付けRange("C 2:D 2"&aa).Select Select Selection.Copy Range("C 2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False
End Sub 11------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'Worksheets("分割M 2モデル").Visible=Flash'Worksheets("分割M 2分割リスト").Visible=Flash MsgBox-t&"秒完了へへへ"'プログラム実行後プロンプト完了時間Sheets("単純透視").Activate Sheets("単純透視").Range("a 1:ab 1").Select Application.EnableEvents=True'シャットダウンイベント、トリガ防止、実行速度の向上Application.ScreenUpdating=True'シャットダウン画面更新、マクロの実行プロセスは見えないが、マクロの実行速度の向上End Sub
3--------------------------------------------------------------------------------------------------------------'シングル契約Application.ScreenUpdating=False'画面更新をオフにするとマクロの実行プロセスは見えませんが、マクロの実行速度を上げるApplication.EnableEvents=False'イベントをオフにして、トリガーを防止し、実行速度を上げる'Windowsのコピー(「分割M 2分割リスト.xlsm」).Activate'指定ワークブックWorksheets(「シングル契約リスト」).Select'aa=Range(「a 1」)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--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------.Selectaaa=Range("a 1").CurrentRegion.Rows.Count Sheets("分割M 2モデル").Range("A 2:A"&aaaaa).ClearContents Sheets("分割分割リスト").Selectam=Range("b 1").CurrentRegion.Rows.Count'最大行Range("B 2:B"&am).SelectSelectSelection.Copy Sheets("分割M 2モデル").SelectRange("分割M 2モデル").SelectRange("A 2’).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False,Transpose:=False End Sub Sub con 11()'従業員数Worksheets("分割M 2モデル").Select Range("D 1").ClearContents am=Range("a 1").CurrentRegion.Rows.Count'最大行Cells(1,4)=Application.WorksheetFunction.Counta(Range("a 2:a"&am))'実行counta関数(統計テキスト個数)
End Sub 6-----------------------------------------------------従業員数および催促対象契約量1 Subcon 22()'催促対象契約量Worksheets("分割M 2モデル").Range("G 1").ClearContents Windows("分割M 2分割リスト.xlsm").Activate Worksheets("単一契約リスト").Select BB=Range("b 1").CurrentRegion.Rows.Count Worksheets("分割M 2モデル").cells(1,7)=Application.WorksheetFunction.Counta(Range("b 2:b"&BB)'実行counta関数(統計テキスト個数)End Sub Sub統計従業員数および催促契約量1()'単契約con 11 con 22 Worksheets("分割M 2モデル").Select Range("g 1").Select End Sub 7-----------------------------------------------------整数サイクル1 Sub整数サイクル1()'単契約'Windows(「ランダム・シナリオモデル.xlsm」).Activate'p=Range("E 1").CurrentRegion.Rows.Clont'選択最大行Windows("分割M 2シナリオリスト.xlsm").Activate'指定ワークブックWorkshets("分割M 2モデル").Range("E 2:E 50000").ClearContents'実行前に指定領域n=Range("d 1").Value m=Range("d 2").Value Dim arr()Diarr()Diarr(()Diarr(1 Ton)For i=2 Ton+1 arr(i-1)=Range("a"&i).Value Next i Fori=1 Tom Range("e 100000").End(xlUp).Offset(1,0).Resize(n,1)=WorkshetFunction.Transpose(arr)Next i End Sub 8---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------Worksheets(「分割M 2モデル").Select'指定ワークシートEE=Range("E 1").CurrentRegion.Rows.Count'最大行aa=Range("A 1").CurrentRegion.Rows.Count'選択最大行b=Range("g 3")Ifb>=1 Then Range("A 2: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を向上させる(「シングル契約リスト」).Selectaa=Range("a 1").CourrentRegion.Rows.CountWorkshets("単一契約明細書").Range("AT 2:AW 2"&aaa).ClearContents'毎回実行前クリアテーブルWorkshets("分割M 2モデル").Selectaaa=Range("E 1").CourrentRegion.Rows.Count Range("E 2:E"&aaa).Select'Range(Selection,Selection.End(xlDown.End(xlDown.End(xlDown.End)).Select Selection.Copy ActiveWindow.SmallScroll Down:=3 Sheets("単一契約リスト").Select ActiveWindow.SmallScroll Down:=-9 Range("AT 2").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---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------.ClearContents'の実行はSheets("分割リスト").Select aa=Range("a 1").CurrentRegion.Rows.Count Range("B 2:C 2"&aa).Select Selection.Copy Sheets("単純透視").Select Row=Range("b 1").CurrentRegion.Rows.Count Range("A 2")のみを先にクリアする.SelectSelection.PasteSpecial Paste:=xlPasteValues,Operation:= xlNone,SkipBlanks_:=False,Transpose:=False Range("C 2").SelectApplication.CuCopyMode=False Workshets("単一契約リスト").Selectab=Range("a 1").CurrentRegion.Rows.Cows.Cows("単純透視").SelectRow=Range("a 1").CurrentRerentRegion.Rows.Rows("単純透視").SelectRow=Range("a 1")tRegion.Rows.Count For i=2 To Row
Cells(i, 3) = WorksheetFunction.CountIf(Worksheets(" ").Range("AT2:AT" & ab), Worksheets(" ").Range("a" & i))
Next i
'ActiveCell.FormulaR 1 C 1="=COUNTIF(単一契約リスト!C[46]、単純透視!RC[-1])''countif関数'Range("C 2").AutoFill Destination:=Range("C 2:C"&aa)、Type:=xlFillDefault'充填Fori=2 To Row Cells(i,4)=WorkshetFunction.SumIf(Workshets("単一契約リスト").Range("AT 2:AT"&ab)、Workshets("単純ピボット").Range("a"&i),Worksheets("単一契約明細書").Range("K 2:K"&ab))Next i
'Range("D 2").Select'ActiveCell.FormulaR 1 C 1="=SUMIF(シングル契約リスト!C[46]、単純透視!RC[-2]、シングル契約リスト!C[11])"'sumif関数'Range("D 2").AutoFill Destination:=Range("D 2:D"&aa)、Type:=xlFillDefault'充填'コピーを削除して公式化貼り付けRange("C 2:D 2"&aa).Select Select Selection.Copy Range("C 2").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------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Application.ScreenUpdating = False ' ， ，
Application.EnableEvents = False ' ， ，
t = Timer '
Windows(" M2 .xlsm").Activate
1
1
1
1
1
1
1
1
'Worksheets("分割M 2モデル").Visible=Flash'Worksheets("分割M 2分割リスト").Visible=Flash MsgBox-t&"秒完了へへへ"'プログラム実行後プロンプト完了時間Sheets("単純透視").Activate Sheets("単純透視").Range("a 1:ab 1").Select Application.EnableEvents=True'シャットダウンイベント、トリガ防止、実行速度の向上Application.ScreenUpdating=True'シャットダウン画面更新、マクロの実行プロセスは見えないが、マクロの実行速度の向上End Sub