VBA: Find value of A1, Sht1 in Sht2, copy Sht2 row to Sht3. Repeat through Sht1 range.

melevad

New Member
Joined
Feb 8, 2006
Messages
9
Hello,
I've looked for code already posted but am not finding what I need exactly. I'm not that good with VBA so I hope someone can post some code I an run with.

I have sheets in a workbook:
Sheet1 has a range of values in column 1 (I.E. A1 through A1000).
Sheet2 has 1000s of rows of data (I.E. A1 through XX3000). Most, but not all, of the values in the range of Sheet1 will be found in column G in Sheet2.
Sheet3 is empty.

I am looking to:
  • Get value from A1, sheet1.
  • Find match of that value in column G of sheet2.
  • Copy the entire row where the match is found in sheet2 to row 1, sheet 3.
  • Repeat above for the range of values in Sheet1 (copying to the next incremented row in Sheet3) for each repetition.
  • If no match is found, create a new incremented row on Sheet3 anyway and place the value from Sheet1 in the column G cell.
Your help is greatly appreciated!
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,614
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
Sub melevad()
   Dim Ary As Variant
   Dim r As Long, NxtRw As Long
   Dim Dic As Object
   Dim Sht3 As Worksheet
   
   Set Sht3 = Sheets("Sheet3")
   Set Dic = CreateObject("scripting.dictionary")
   Dic.comparemode = 1
   NxtRw = 1
   
   With Sheets("Sheet2")
      Ary = .Range("G1", .Range("G" & Rows.Count).End(xlUp)).Value2
   End With
   For r = 1 To UBound(Ary)
      Dic(Ary(r, 1)) = r
   Next r
   With Sheets("Sheet1")
      Ary = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value2
   End With
   With Sheets("Sheet2")
      For r = 1 To UBound(Ary)
         If Dic.Exists(Ary(r, 1)) Then
            .Rows(Dic(Ary(r, 1))).Copy Sht3.Range("A" & NxtRw)
         Else
            Sht3.Range("G" & NxtRw).Value = Ary(r, 1)
         End If
         NxtRw = NxtRw + 1
      Next r
   End With
End Sub
 
Solution

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,614
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,685
Messages
5,637,808
Members
416,983
Latest member
LessThanAverageUser

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top