Find and move to specified location

[Lilly44]

Hi,
I have a spreadsheet within a worksheet that contains a variety of headers (each in duplicate). For example, carrot carrot milk milk eggs eggs, etc

I need to be able to find the values under each header and transfer to a defined column on a second spreadsheet which lists them in a particular (correct order). For example, I need to find the values under each of the eggs columns in spreadsheet 1 and move them to columns A and B in spreadsheet 2. Is there an easy way to do this?

Thanks for your help!

 

[mumps]

Are the duplicate headers in Sheet1 always beside each other?

 

[Lilly44]

Are the duplicate headers in Sheet1 always beside each other?

Yes, they are.

 

[mumps]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, x As Long, lCol As Long, Header As Range, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(1, Columns.Count).End(xlToLeft).Column
    For x = 1 To lCol Step 2
        Set Header = desWS.Rows(1).Find(srcWS.Cells(1, x).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not Header Is Nothing Then
            If Header.Column = 2 Then
                srcWS.Cells(2, x).Resize(LastRow - 1, 2).Copy desWS.Cells(2, 1)
            Else
                srcWS.Cells(2, x).Resize(LastRow - 1, 2).Copy desWS.Cells(2, Header.Column)
            End If
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Lilly44]

Hi Mumps,
Thank you so much for your help and I'm sorry I had not responded sooner.
The code you gave me works I just need to make it start on the second column (for both the source and destination sheets) because the first column has the sample names.

 

[mumps]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, x As Long, lCol As Long, Header As Range, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = srcWS.Cells(1, Columns.Count).End(xlToLeft).Column
    For x = 2 To lCol Step 2
        Set Header = desWS.Rows(1).Find(srcWS.Cells(1, x).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not Header Is Nothing Then
            srcWS.Cells(2, x).Resize(LastRow - 1, 2).Copy desWS.Cells(2, Header.Column)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Lilly44]

Ah..this one works perfectly
Thank you so much again!!!

 

[mumps]

You are very welcome.