A brief overview of the problem at hand:
There are two workbooks 'ACP.xlsm' and 'Reference.xlsm'. The code must compare a value (from 3rd row) in column A of ACP.xlsm workbook to a value (rows from A2 of) in column A of Reference.xlsm work book or column B, C in that order. If a match is found then it should offset one step from column A in ACP.xlsm to coumn B in ACP.xlsm and check for a value "WS Groups Totals:" in that column and when it finds the first instance of the value, it should stop checking and copy the range of rows from the row when Column A in ACP.xlsm matched with a value in Column (A or B or C ) in Reference .xlsm and paste it in separate worksheet in ACP.xlsm. I have written a code for the purpose but when I run this code it keeps on throwing me the error that subscript is out of range (Error:9)...can you please help me run this code or suggest a better code...I am a beginner and I am at my wits end...thank you...I have attached my data files for your reference in case my description is not clear...
My code:
Option Explicit
Sub GetMatches()
Dim PartRngWorkbook1Sheet1 As Range, PartRngWorkbook2Sheet1 As Range
Dim lastRowWorkbook1Sheet1 As Long, lastRowWorkbook2Sheet1 As Long
Dim cl As Range, rng As Range
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
lastRowWorkbook1Sheet1 = Workbooks("ACP.xlsm").Worksheets("Sheet1").Range("A65536").End(xlUp).Row
Set PartRngWorkbook1Sheet1 = Workbooks("ACP.xlsm").Worksheets("Sheet1").Range("A3:A" & lastRowWorkbook1Sheet1)
lastRowWorkbook2Sheet1 = Workbooks("Reference.xlsm").Worksheets("Sheet1").Range("A65536").End(xlUp).Row
Set PartRngWorkbook2Sheet1 = Workbooks("Reference.xlsm").Worksheets("Sheet1").Range("A2:A" & lastRowWorkbook2Sheet1)
For Each cl In PartRngWorkbook1Sheet1
For Each rng In PartRngWorkbook2Sheet1
If cl = rng Then
LSearchRow = ActiveCell.Row 'Have a doubt here
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet2").Rows(1)
If Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:" Then
Rows(CStr(ActiveCell.Row) & ":" & CStr(LSearchRow)).Select 'Have a doubt here
Selection.Copy
Workbooks("ACP.xlsm").Worksheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet2").End(xlUp).Row + 1
Workbooks("ACP.xlsm").Worksheets("Sheet1").Select
End If
Do Until Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:"
LSearchRow = LSearchRow + 1
Loop
Else
If cl = rng.Offset(0, 1) Then
LSearchRow = ActiveCell.Row 'Have a doubt here
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet3").Rows(1)
If Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:" Then
Rows(CStr(ActiveCell.Row) & ":" & CStr(LSearchRow)).Select 'Have a doubt here
Selection.Copy
Workbooks("ACP.xlsm").Worksheets("Sheet3").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet3").End(xlUp).Row + 1
Workbooks("ACP.xlsm").Worksheets("Sheet1").Select
End If
Do Until Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:"
LSearchRow = LSearchRow + 1
Loop
Else
If cl = rng.Offset(0, 2) Then
LSearchRow = ActiveCell.Row 'Have a doubt here
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet4").Rows(1)
If Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:" Then
Rows(CStr(ActiveCell.Row) & ":" & CStr(LSearchRow)).Select 'Have a doubt here
Selection.Copy
Workbooks("ACP.xlsm").Worksheets("Sheet4").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet4").End(xlUp).Row + 1
Workbooks("ACP.xlsm").Worksheets("Sheet1").Select
End If
Do Until Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:"
LSearchRow = LSearchRow + 1
Loop
Else
Print "New Workstation group found in Workbook1"
End If
End If
End If
Next rng
Next cl
End Sub
There are two workbooks 'ACP.xlsm' and 'Reference.xlsm'. The code must compare a value (from 3rd row) in column A of ACP.xlsm workbook to a value (rows from A2 of) in column A of Reference.xlsm work book or column B, C in that order. If a match is found then it should offset one step from column A in ACP.xlsm to coumn B in ACP.xlsm and check for a value "WS Groups Totals:" in that column and when it finds the first instance of the value, it should stop checking and copy the range of rows from the row when Column A in ACP.xlsm matched with a value in Column (A or B or C ) in Reference .xlsm and paste it in separate worksheet in ACP.xlsm. I have written a code for the purpose but when I run this code it keeps on throwing me the error that subscript is out of range (Error:9)...can you please help me run this code or suggest a better code...I am a beginner and I am at my wits end...thank you...I have attached my data files for your reference in case my description is not clear...
My code:
Option Explicit
Sub GetMatches()
Dim PartRngWorkbook1Sheet1 As Range, PartRngWorkbook2Sheet1 As Range
Dim lastRowWorkbook1Sheet1 As Long, lastRowWorkbook2Sheet1 As Long
Dim cl As Range, rng As Range
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
lastRowWorkbook1Sheet1 = Workbooks("ACP.xlsm").Worksheets("Sheet1").Range("A65536").End(xlUp).Row
Set PartRngWorkbook1Sheet1 = Workbooks("ACP.xlsm").Worksheets("Sheet1").Range("A3:A" & lastRowWorkbook1Sheet1)
lastRowWorkbook2Sheet1 = Workbooks("Reference.xlsm").Worksheets("Sheet1").Range("A65536").End(xlUp).Row
Set PartRngWorkbook2Sheet1 = Workbooks("Reference.xlsm").Worksheets("Sheet1").Range("A2:A" & lastRowWorkbook2Sheet1)
For Each cl In PartRngWorkbook1Sheet1
For Each rng In PartRngWorkbook2Sheet1
If cl = rng Then
LSearchRow = ActiveCell.Row 'Have a doubt here
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet2").Rows(1)
If Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:" Then
Rows(CStr(ActiveCell.Row) & ":" & CStr(LSearchRow)).Select 'Have a doubt here
Selection.Copy
Workbooks("ACP.xlsm").Worksheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet2").End(xlUp).Row + 1
Workbooks("ACP.xlsm").Worksheets("Sheet1").Select
End If
Do Until Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:"
LSearchRow = LSearchRow + 1
Loop
Else
If cl = rng.Offset(0, 1) Then
LSearchRow = ActiveCell.Row 'Have a doubt here
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet3").Rows(1)
If Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:" Then
Rows(CStr(ActiveCell.Row) & ":" & CStr(LSearchRow)).Select 'Have a doubt here
Selection.Copy
Workbooks("ACP.xlsm").Worksheets("Sheet3").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet3").End(xlUp).Row + 1
Workbooks("ACP.xlsm").Worksheets("Sheet1").Select
End If
Do Until Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:"
LSearchRow = LSearchRow + 1
Loop
Else
If cl = rng.Offset(0, 2) Then
LSearchRow = ActiveCell.Row 'Have a doubt here
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet4").Rows(1)
If Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:" Then
Rows(CStr(ActiveCell.Row) & ":" & CStr(LSearchRow)).Select 'Have a doubt here
Selection.Copy
Workbooks("ACP.xlsm").Worksheets("Sheet4").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = Workbooks("ACP.xlsm").Worksheets("Sheet4").End(xlUp).Row + 1
Workbooks("ACP.xlsm").Worksheets("Sheet1").Select
End If
Do Until Range("cl.offset(0,1)" & CStr(LSearchRow)).Value = "WS Group Totals:"
LSearchRow = LSearchRow + 1
Loop
Else
Print "New Workstation group found in Workbook1"
End If
End If
End If
Next rng
Next cl
End Sub
Last edited: