run-time error '9' Subscript out of range

[PGNewbie]

I am matching two columns in a new workbook with two columns in Workbook 2, and then retrieving column B from Workbook2 and copying it to column B in the new workbook. Some cells will be empty.

Sub InsertDeviceName_NewBook()

Dim w1 As Worksheet, w2 As Worksheet, wsnew As Worksheet
      Dim wbnew As Workbook
      Dim c As Range, FR As Variant
      Dim d As Range
      Dim e As Range 'rng1 As Range, rng2 As Range
      Dim lr1 As Long, lr2 As Long
      Dim x As Long, i As Long, lr As Long
      Dim rng1 As Variant, rng2 As Variant
      Dim vals()
      

      Application.ScreenUpdating = False
      
      
      Set w2 = Workbooks("Book2.xlsx").ActiveSheet
      Set w1 = Workbooks("Book1.xlsx").ActiveSheet
      
      
      
     w1.Range("B:D").Copy
     Set wbnew = Workbooks.Add
     Columns("A:A").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
     ActiveSheet.Name = w1.Name
     Set wsnew = wbnew.ActiveSheet
     lr1 = wsnew.Cells(Rows.count, 1).End(xlUp).Row
     lr2 = w2.Cells(Rows.count, 1).End(xlUp).Row
    
    
     wsnew.Sort.SortFields.Add2 Key:=Range("B1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With wsnew.Sort
        .SetRange Range("A1:C" & lr1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
 
 End With
    
Columns("B:B").Insert Shift:=xlToRight, _
      CopyOrigin:=xlFormatFromLeftOrAbove
      
      Range("B1").Select
      ActiveCell.FormulaR1C1 = "Device Name"
      
    

rng1 = wsnew.Range("C2", wsnew.Range("D" & wsnew.Cells(Rows.count, 1).End(xlUp).Row)).Value
rng2 = w2.Range("C2", w2.Range("D" & w2.Cells(Rows.count, 1).End(xlUp).Row)).Value


ReDim vals(1 To UBound(rng1, 1), 1)
For x = 1 To UBound(rng1, 1)
    For i = 1 To UBound(rng2)
        If rng1(x, 2) = rng2(i, 2) Then
            If rng1(x, 3) = rng2(i, 3) Then 'causes error
                vals(x, 0) = rng2(i, 2)
                GoTo Nextone
            End If
        End If
    Next i
Nextone:
Next x

ws1.Range("B2").Resize(UBound(vals, 1), 1).Value = vals

Application.ScreenUpdating = True

End Sub

 

[Fluff]

Both rng1 & rng2 are 2 columns wide, but you are trying to look at the 3rd column.

 

[DanteAmor]

I have not tested the code, but you are only loading 2 columns, so column 1 of the array is for "C" and column 2 of the array is for "D", then:

ReDim vals(1 To UBound(rng1, 1), 1)
For x = 1 To UBound(rng1, 1)
    For i = 1 To UBound(rng2)
        If rng1(x, 1) = rng2(i, 1) Then
            If rng1(x, 2) = rng2(i, 2) Then 'causes error
                vals(x, 0) = rng2(i, 1)
                GoTo Nextone
            End If
        End If
    Next i
Nextone:
Next x

 

[PGNewbie]

Both rng1 & rng2 are 2 columns wide, but you are trying to look at the 3rd column.

Thank you, rng2 should have had 3 columns in the range. I readjusted my code and it worked perfectly. As always Fluff your suggestions and help are invaluable.

 

[Fluff]

Glad we could help & thanks for the feedback

 

[PGNewbie]

I have not tested the code, but you are only loading 2 columns, so column 1 of the array is for "C" and column 2 of the array is for "D", then:

ReDim vals(1 To UBound(rng1, 1), 1)
For x = 1 To UBound(rng1, 1)
    For i = 1 To UBound(rng2)
        If rng1(x, 1) = rng2(i, 1) Then
            If rng1(x, 2) = rng2(i, 2) Then 'causes error
                vals(x, 0) = rng2(i, 1)
                GoTo Nextone
            End If
        End If
    Next i
Nextone:
Next x

Thank you DanteAmor, I realized that and adjusted my code, running smoothly now

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.