How to run a compare though multiple sheets? - excel

Question

I'm trying to run a compare though multiple sheets.
I get
Runtime error 9 subscript out of range
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
The following works but then I need to make a Sub for at the moment 26 sheets which could be more later. I don't want to make another Sub each time that happens.
Or I may also need to delete a sheet then I would have delete that 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