VBA Check if value in Sheet1 exists in Sheet2 then copy specific rows from Sheet2 into Sheet1

[Brandon_s]

Hi All,

I am trying to write a VBA code to perform the task mentioned in the title. Here are the specifics:

Notes:
-The function needs to loop from row 1 to the last row that contains a value (in Sheet1). The range can be a static range for Sheet2.
-Row A will always be used for the check between Sheet1 and Sheet2 to see if a matching value exists

Goal:
-Loop from row A1 to the last row that contains a value in sheet 1 to see if these values exist in Sheet 2.
-For all values that do exist in Sheet2, I need to find the associated sub parts under that value and copy the range of rows for those parts
-The amount of sub parts will change for every instance but they will always start in column B at matching row +1 and they will end with the next blank in column B
-As an example, if a matching part is found in A4 on Sheet2, and the associated sub parts are in cells B5 through B9, I need to copy rows 5-9 (with B10 being the blank value the code found)
-Insert the copied rows from Sheet2 into Sheet1 one row below the value that matched.
-For example, if cell A1 on Sheet1 contains the value that matched cell A4 on Sheet2, insert rows B5 through B9 from Sheet2 one row below A1 on Sheet1.

I apologize if this is unclear, it is hard to convey the information properly without attaching a sample workbook.

Thank you for the help.

 

[JLGWhiz]

Assuming you mean Column A as opposed to Row A.

Sub copyStuff()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, fn As Range, sr As Range, rng As Range, n As Long
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 2 Step -1
        Set fn = sh2.Range("A:A").Find(sh1.Cells(i, 1).Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                Set sr = fn.Offset(1, 1)
                If sr <> "" And sr.Offset(1) <> "" Then
                    Set er = sr.End(xlDown)
                    Set rng = sh2.Range(sr, er)
                Else
                    rng = sr
                End If
                n = rng.Rows.Count
                rng.EntireRow.Copy
                sh1.Cells(i, 1).Offset(1).Resize(n).EntireRow.Insert
            End If
    Next
End Sub

 

[Brandon_s]

JLGWhiz,

Yes I meant Column A - my apologies. I tried running the code on a sample that emulates my real file and I get the following error:

"Object variable or With block variable not set"

Debugger highlights line item 14 where "rng = sr" and it says rng = Nothing.

It looks like rng is definited in row 12 where you set rng = sh2.Range(sr,er) so I am unsure how to fix this.

Thank you

 

[JLGWhiz]

JLGWhiz,

Yes I meant Column A - my apologies. I tried running the code on a sample that emulates my real file and I get the following error:

"Object variable or With block variable not set"

Debugger highlights line item 14 where "rng = sr" and it says rng = Nothing.

It looks like rng is definited in row 12 where you set rng = sh2.Range(sr,er) so I am unsure how to fix this.

Thank you

Yep, my error. Try this one.

Sub copyStuff2()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, fn As Range, sr As Range, rng As Range, n As Long
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 2 Step -1
        Set fn = sh2.Range("A:A").Find(sh1.Cells(i, 1).Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                Set sr = fn.Offset(1, 1)
                If sr <> "" And sr.Offset(1) <> "" Then
                    Set er = sr.End(xlDown)
                    Set rng = sh2.Range(sr, er)
                Else
                    Set rng = sr
                End If
                n = rng.Rows.Count
                rng.EntireRow.Copy
                sh1.Cells(i, 1).Offset(1).Resize(n).EntireRow.Insert
            End If
    Next
End Sub

 

[Brandon_s]

This worked beautifully, thank you so much for the help!

 

[JLGWhiz]

This worked beautifully, thank you so much for the help!

You're welcome,
regards, JLG

 

[deepak30]

Yep, my error. Try this one.

Sub copyStuff2()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, fn As Range, sr As Range, rng As Range, n As Long
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 2 Step -1
        Set fn = sh2.Range("A:A").Find(sh1.Cells(i, 1).Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                Set sr = fn.Offset(1, 1)
                If sr <> "" And sr.Offset(1) <> "" Then
                    Set er = sr.End(xlDown)
                    Set rng = sh2.Range(sr, er)
                Else
                    Set rng = sr
                End If
                n = rng.Rows.Count
                rng.EntireRow.Copy
                sh1.Cells(i, 1).Offset(1).Resize(n).EntireRow.Insert
            End If
    Next
End Sub

Superb Sir I have tried different type of vba to split sheet as per master(sheet1) but it took ample amount of time to go through sheet2 but this took some 1 to 2 min great sir