Find then copy specific row from SHT2 to new row in SHT1...

[melevad]

Hello and Happy Friday!
The thread title is shy on detail but any help with the following task would be greatly appreciated!

I have two sheets, SHT1 & SHT2, that have 1000+ rows. The rows in both sheets have varying numbers of cells populated- some rows have data out to column P others out to column X. The cells in column G of both sheets contain a value that is unique within that column on that sheet. Most or all of the unique values in SHT1 are also present in SHT2, but they appear on different row numbers. What I need to do is this:

1) Learn the unique value from cell G1<current row> in SHT1.

2) Search for that value in column G of SHT2.
* If there is a match, copy entire row to buffer then go to step 3)
* If there is not a match, go back to step 1) and increment to next row (I.E. G2<new current row>).

3) Insert a new row in SHT1 below the current row.

4) Paste the row from SHT2 to the new row created in SHT1.

5) Shade all the cells yellow in the newly created row in SHT1. (this is a "nice to have" optional step)

6) Repeat 1) - 5) incrementing down 1 row at a time in SHT1 until a blank F<n> cell is encountered, then end program.

 

[rollis13]

Have a try with my macro to be pasted in a vbe module:

Option Explicit
Sub Search_Copy_Insert()
    Dim lrSh1    As Long
    Dim lrSh2    As Long
    Dim lcSh1  As Long
    Dim rowColG   As Long
    Dim findColG As Range
    Dim sh1    As Worksheet
    Dim sh2    As Worksheet
    Application.ScreenUpdating = False
    Set sh1 = Sheets("SHT1")
    Set sh2 = Sheets("SHT2")
    lrSh1 = sh1.Range("G" & Rows.Count).End(xlUp).Row 'last row SHT1 column G
    lrSh2 = sh2.Range("G" & Rows.Count).End(xlUp).Row 'last row SHT2 column G
    For rowColG = lrSh1 To 1 Step -1              'loop through column G of SHT1
        Set findColG = sh2.Range("G1:G" & lrSh2).Find(What:=sh1.Cells(rowColG, "G"), LookIn:=xlValues, LookAt:=xlWhole) 'search in SHT2 column G
        If Not findColG Is Nothing Then           'if found ...
            sh2.Cells(findColG.Row, 1).EntireRow.Copy
            sh1.Cells(rowColG, 1).Insert Shift:=xlDown
            lcSh1 = sh1.Cells(rowColG + 1, Cells.Columns.Count).End(xlToLeft).Column + 1 'find last column
            sh1.Range(Cells(rowColG + 1, 1), Cells(rowColG + 1, lcSh1)).Interior.ColorIndex = 6 'apply backgound color
        End If
    Next rowColG
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

 

[melevad]

Have a try with my macro to be pasted in a vbe module:

Option Explicit
Sub Search_Copy_Insert()
    Dim lrSh1    As Long
    Dim lrSh2    As Long
    Dim lcSh1  As Long
    Dim rowColG   As Long
    Dim findColG As Range
    Dim sh1    As Worksheet
    Dim sh2    As Worksheet
    Application.ScreenUpdating = False
    Set sh1 = Sheets("SHT1")
    Set sh2 = Sheets("SHT2")
    lrSh1 = sh1.Range("G" & Rows.Count).End(xlUp).Row 'last row SHT1 column G
    lrSh2 = sh2.Range("G" & Rows.Count).End(xlUp).Row 'last row SHT2 column G
    For rowColG = lrSh1 To 1 Step -1              'loop through column G of SHT1
        Set findColG = sh2.Range("G1:G" & lrSh2).Find(What:=sh1.Cells(rowColG, "G"), LookIn:=xlValues, LookAt:=xlWhole) 'search in SHT2 column G
        If Not findColG Is Nothing Then           'if found ...
            sh2.Cells(findColG.Row, 1).EntireRow.Copy
            sh1.Cells(rowColG, 1).Insert Shift:=xlDown
            lcSh1 = sh1.Cells(rowColG + 1, Cells.Columns.Count).End(xlToLeft).Column + 1 'find last column
            sh1.Range(Cells(rowColG + 1, 1), Cells(rowColG + 1, lcSh1)).Interior.ColorIndex = 6 'apply backgound color
        End If
    Next rowColG
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

Hello and thank you @rollis13! Your macro works except for one thing that I have been trying to tweak but I'm not having success: It is inserting the new row above instead of below the row that was found on SHT1. Is it a simple fix?

 

[rollis13]

Probably was my mistake (typo), change this line to this, it should be enough:

sh1.Cells(rowColG + 1, 1).Insert Shift:=xlDown

and here was another typo, change to this:

lcSh1 = sh1.Cells(rowColG + 1, Cells.Columns.Count).End(xlToLeft).Column 'find last column

 

[melevad]

Th

Probably was my mistake (typo), change this line to this, it should be enough:

sh1.Cells(rowColG + 1, 1).Insert Shift:=xlDown

and here was another typo, change to this:

lcSh1 = sh1.Cells(rowColG + 1, Cells.Columns.Count).End(xlToLeft).Column 'find last column

Thanks again for taking the time! Much appreciated! I managed to get it to work by adding the " + 1" (bold font below) to the original code you suggested:
Option Explicit
Sub Search_Copy_Insert()
Dim lrSh1 As Long
Dim lrSh2 As Long
Dim lcSh1 As Long
Dim rowColG As Long
Dim findColG As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Sheets("SHT1")
Set sh2 = Sheets("SHT2")
lrSh1 = sh1.Range("G" & Rows.Count).End(xlUp).Row 'last row SHT1 column G
lrSh2 = sh2.Range("G" & Rows.Count).End(xlUp).Row 'last row SHT2 column G
For rowColG = lrSh1 To 1 Step -1 'loop through column G of SHT1
Set findColG = sh2.Range("G1:G" & lrSh2).Find(What:=sh1.Cells(rowColG, "G"), LookIn:=xlValues, LookAt:=xlWhole) 'search in SHT2 column G
If Not findColG Is Nothing Then 'if found ...
sh2.Cells(findColG.Row, 1).EntireRow.Copy
sh1.Cells(rowColG + 1, 1).Insert Shift:=xlDown
lcSh1 = sh1.Cells(rowColG + 1, Cells.Columns.Count).End(xlToLeft).Column + 1 'find last column
sh1.Range(Cells(rowColG + 1, 1), Cells(rowColG + 1, lcSh1)).Interior.ColorIndex = 6 'apply backgound color
End If
Next rowColG
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

 

[rollis13]

Thanks for the positive feedback, glad having been of some help. But you didn't get rid of the other +1 which was highlighting one extra cell on the row.

 

[melevad]

Thanks for the positive feedback, glad having been of some help. But you didn't get rid of the other +1 which was highlighting one extra cell on the row.

Indeed! Thank you again!