How to run a compare though multiple sheets?

user_17988924 0
Viewed 72

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
compare vba excel loops
1 Answers
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
user_127045930
Related