A Macro That Matches then Copies Data

[rwmill9716]

I need a macro that will:

1. On Sheet 1, Read Cell A8's value (here 3)
2. Match that value with the values in row 2 (here Col D)
3. Copy the Matched Column to Column A of another Sheet (Sheet2)

Here, I show that copy in Col G, but I need it copied onto another Sheet

Note, my real data set will have many more columns of data to choose from (and the columns of data will be much longer (~50 cells)

Thanks in advance for your help.

Ric

Excel 2010
	A	B	C	D	E	F	G
1		Data 1	Data 2	Data 3	Data 4		Data 3
2	Match Row	1	2	3	4		3
3		2	3	4	5		4
4		3	4	5	6		5
5		4	5	6	7		6
6		5	6	7	8		7
7	Match	6	7	8	9		8
8	3	7	8	9	10		9
9		8	9	10	11		10
10		9	10	11	12		11
11		10	11	12	13		12
Sheet1

 

[JLGWhiz]

What is not specified is whether the will be more than one occurrence of the target value in row 2.

Sub matchNcopy()
Dim sh1 As Worksheet, sh2 As Worksheet, fn As Range, fAdr As String
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
    Set fn = sh1.Range("B2", sh1.Cells(2, Columns.Count).End(xlToLeft)).Find(sh1.Range("A8").Value, , xlValues, xlWhole)
        If Not fn Is Nothing Then
            fAdr = fn.Address
            Do
                If sh2.Range("A1") = "" Then
                    fn.EntireColumn.Copy sh2.Range("A1")
                Else
                    fn.EntireColumn.Copy sh2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
                End If
                Set fn = sh1.Range("B2", sh1.Cells(2, Columns.Count).End(xlToLeft)).FindNext(fn)
            Loop While fAdr <> fn.Address
        End If
End Sub

 

[rwmill9716]

Thanks, JLGWhiz, this works fine.

Ric

 

[JLGWhiz]

Thanks, JLGWhiz, this works fine.

Ric

You're welcome,
Regards, JLG