如何在多张图纸之间进行比较

Question

我正在尝试对多张工作表进行比较。

我得到

运行时错误9下标超出范围

Sub Comp_TEST()
Dim ar As Variant
Dim var()
Dim i As Long
Dim n As Long
Dim Last_Row As Long
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> "GALVANISED" And WS.Name <> "ALUMINUM" And WS.Name <> "LOTUS" And WS.Name <> "TEMPLATE" And WS.Name <> "SCHEDULE CALCULATIONS" And WS.Name <> "TRUSS" And WS.Name <> "DASHBOARD CALCULATIONS" And WS.Name <> "GALVANISING CALCULATIONS" Then
WS.Range("D3:D1000").Copy
WS.Range("O3").PasteSpecial xlPasteValues
WS.Range("K3:K1000").Copy
WS.Range("N3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ar = WS.Range("N3").CurrentRegion
ReDim var(1 To UBound(ar, 1), 1 To 1)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(ar, 1)
.Item(ar(i, 2)) = Empty
Next
For i = 1 To UBound(ar, 1)
If Not .exists(ar(i, 1)) Then
n = n + 1
var(n, 1) = ar(i, 1) 'error happens here
End If
Next
End With
WS.[P3].Resize(n).Value = var
Erase var
ReDim var(1 To UBound(ar, 1), 1 To 1)
Last_Row = WS.Range("D2").End(xlDown).Offset(1).Row
WS.Range("P3:P1000").Copy
WS.Range("D" & Last_Row).PasteSpecial xlPasteValues
WS.Range("N3:P1000").ClearContents

End If
Next WS
End Sub

以下工作，但我现在需要为26张纸做一个Sub，以后可能会更多。我不想每次都做另一个Sub。

或者我可能还需要删除一张表，然后我必须删除该子

Sub Comp_ALL_VANS()
Dim ar As Variant
Dim var()
Dim i As Long
Dim n As Long
Dim Last_Row As Long
Worksheets("ALL VANS").Range("D3:D1000").Copy
Worksheets("ALL VANS").Range("O3").PasteSpecial xlPasteValues
Worksheets("ALL VANS").Range("K3:K1000").Copy
Worksheets("ALL VANS").Range("N3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ar = Worksheets("ALL VANS").Range("N3").CurrentRegion
ReDim var(1 To UBound(ar, 1), 1 To 1)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(ar, 1)
.Item(ar(i, 2)) = Empty
Next
For i = 1 To UBound(ar, 1)
If Not .exists(ar(i, 1)) Then
n = n + 1
var(n, 1) = ar(i, 1)
End If
Next
End With
Worksheets("ALL VANS").[P3].Resize(n).Value = var
Last_Row = Worksheets("ALL VANS").Range("D2").End(xlDown).Offset(1).Row
Worksheets("ALL VANS").Range("P3:P1000").Copy
Worksheets("ALL VANS").Range("D" & Last_Row).PasteSpecial xlPasteValues
Worksheets("ALL VANS").Range("N3:P1000").ClearContents
End Sub

Answer 1

Option Explicit
Sub Comp_TEST()
Dim ws As Worksheet, n As Long   
Dim arSkip
arSkip = Array("GALVANISED", "ALUMINUM", "LOTUS", "TEMPLATE", "SCHEDULE CALCULATIONS", _
"TRUSS", "DASHBOARD CALCULATIONS", "GALVANISING CALCULATIONS")

For Each ws In ActiveWorkbook.Worksheets
If IsError(Application.Match(ws.Name, arSkip, 0)) Then
Call process(ws)
n = n + 1
Else
Debug.Print "Skipped " & ws.Name
End If
Next
MsgBox n & " sheets processed", vbInformation

End Sub
Sub process(ws As Worksheet)

Dim dict As Object, k As String, arK, arD, arNew
Dim n As Long, i As Long, LastRowD As Long, LastRowK as Long
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = 1

With ws

LastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row
If LastRowK < 4 Then LastRowK = 4 ' ensure 2 cells for array
arK = .Range("K3:K" & LastRowK)

LastRowD = .Cells(.Rows.Count, "D").End(xlUp).Row
If LastRowD <= 3 Then
arD = .Range("D3:D4") ' ensure 2 cells for array
If LastRowD < 2 Then LastRowD = 2
Else
arD = .Range("D3:D" & LastRowD)
End If

End With

' array for new
ReDim arNew(1 To UBound(arK), 1 To 1)

' fill dictionary from col D
For i = 1 To UBound(arD)
k = arD(i, 1)
If dict.exists(k) Then
MsgBox "Duplicate key '" & k & "' at D" & i + 2, vbCritical, "Error " & ws.Name
Exit Sub
ElseIf Len(k) > 0 Then
dict.Add k, i
End If
Next

' compare col K  with col D
n = 0
For i = 1 To UBound(arK)
k = arK(i, 1)
If Not dict.exists(k) Then
n = n + 1
arNew(n, 1) = k
End If
Next

' result
If n > 0 Then
ws.Range("D" & LastRowD + 1).Resize(n) = arNew
End If
End Sub