Problem with Excel VBA comparing code not working

[risha185]

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 [B]Runtime error 9 subscript out of range[/B]
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 it will work 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.

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

So what I'm trying to in the first code is the following


-copy from D3:D100 -Paste values into O3
-Copy from K3:K1000 -Paste values into N3
-Compare values in N3 and below with values in O3 then if a value is found in Row O then put that value into P3 and below
-Copy values in O3:O1000
-Paste those values below the last value in row D -Clear the contents of Cells N3:P1000
-Repeat this on each sheet that is not listed up the top


Any help would be appreciated

 

[RoryA]

You need to reset n to 0 for each worksheet.

 

[risha185]

You need to reset n to 0 for each worksheet.

thanks that worked