| |
はじめて質問させていただきます。お世話になります。
素人で申し訳ありませんが、どうぞよろしくお願いいたします。
前月と今月のシートを比較し、
新規データと削除データ、修正があったデータを洗い出すのが目的です。
それぞれ、A列からAN列までデータが入っています。M列からP列は空白です。
見よう見まねで以下の通り作成しましたところ、
データの行が100行くらいであれば問題なく動くのですが、
10万行近くなるとフリーズしてしまいます。
高速化のために"Application.Calculation = xlCalculationManual"を追加すると、
計算式が動かなくなってしまいました。
VLOOKUPの代わりにdictionaryオブジェクトを使うべきかとも思いましたが、
使い方がよくわかりません。
ご教示いただけますと幸甚です。
どうぞよろしくお願いいたします。
Sub Data_compare()
Application.ScreenUpdating = False
Dim LastMonth As Worksheet
Dim ThisMonth As Worksheet
Set LastMonth = Worksheets("前月")
Set ThisMonth = Worksheets("今月")
'データ照合
Dim TheRow1 As Long
Dim TheRow2 As Long
'新規データの明示
'今月のシートと前月のシートを比較。
'今月のシートのL列の数値（重複なし）をキーとし、前月のシートを検索。
'データがあれば、今月のシートのM列は空白のままとする。
'データがなければ、今月のシートのM列に「新規」と入力。
ThisMonth.Select
TheRow2 = Range("A1").CurrentRegion.Rows.Count
Range("M2").Formula = "=IF(ISNA(VLOOKUP(L2,前月!$L:$L,1,FALSE)),""新規"","""")"
Range("M2").Copy
Range("M3:M" & TheRow2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("M:M").Copy
Range("M1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
LastMonth.Select
'後に出てくる「範囲修正」でVLOOKUPを使うが、
'キーがL列で、ピックアップしたい列がG列（左側）のため、
'前月のデータのG列からP列にデータをコピー＆ペースト
Columns(7).Copy
Columns(16).PasteSpecial
'削除データの明示
'前月のシートと前月のシートを比較。
'前月のシートのL列の数値（重複なし）をキーとし、今月のシートを検索。
'データがあれば、前月のシートのM列は空白のままとする。
'データがなければ、前月のシートのM列に「削除」と入力。
TheRow1 = Range("A1").CurrentRegion.Rows.Count
Range("M2").Formula = "=IF(ISNA(VLOOKUP(L2,今月!$L:$L,1,FALSE)),""削除"","""")"
Range("M2").Copy
Range("M3:M" & TheRow1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("M:M").Copy
Range("M1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'範囲修正の明示
'今月のシートのG列と前月のシートのP列（G列のデータをコピーしたもの）を比較。
'M列が空白のデータ（今月と前月のシートの両方にデータが存在するもの）を対象とする。
'今月のシートのL列の数値（重複なし）をキーとし、前月のシートを検索。
'G列とP列のデータに相違がなければM列は空白のままとする。
'G列とP列のデータに相違があれば、M列に「範囲修正」と入力。
ThisMonth.Select
For i = 2 To TheRow2
If Cells(i, 13).Value = "" Then
Cells(i, 13).Formula = "=If(G" & i & "=VLOOKUP(L" & i & ",前月!$L:$P,5,FALSE),"""",""範囲修正"")"
Cells(i, 13).Copy
Cells(i, 13).PasteSpecial Paste:=xlPasteValues
End If
Next
'--並び替え---------------------------------------
'F列を第1キー、A列を第2キーとして並べ替え
LastMonth.Select
Range("A:AN").Sort _
Key1:=Range("F1"), Order1:=xlAscending, _
Key2:=Range("A1"), Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
ThisMonth.Select
Range("A:AN").Sort _
Key1:=Range("F1"), Order1:=xlAscending, _
Key2:=Range("A1"), Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
Application.ScreenUpdating = True
End Sub
|
|
西瓜糖
- 14/7/4(金) 14:14 -
