Problem with Excel VBA comparing code not working-CodePudding

I'm trying to run a compare though multiple sheets but i keep getting an error

"Runtime error 9 subscript out of range"

The code I'm trying to run is

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

but if i just use the following

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

Works but then I need to make a Sub for at the moment 26 sheets which could be more later down the track but i don't want to have to go back in and make another Sub each time that happens.

Or I may also need to delete a sheet then I would have to go in and delete that Sub.

CodePudding user response：

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