Find All, Copy & Paste to Next Blank in Sheet

[Baiano42]

Good morning Excel wizs,

I'm trying to make a Macro that will search Worksheets(1) all headers in ("1:1") for ones containing 'Top' (where one column contain "Top", others contain "Green_Top", "Red_Top", etc.), to copy the entire column (Including header reference) and paste all instances to the next blank column in Worksheets(2)

I've been trying a number of different things, but haven't had any success with it so far. Here is one of the tests that I tried without success:

Dim RowNum As Long    With Worksheets(1)
        Set FoundCell = .Rows(1).Find("Top", , , , xlByColumns, xlNext)
        RowNum = .Cells(.Rows.count, FoundCell.Column).End(xlUp).Row - 1 '-1 for header
    End With
    
    Worksheets(2).Range("C1").Resize(RowNum).Value = FoundCell.Offset(1).Resize(RowNum).Value

[Baiano42]

Another thing that I was thinking of, but also haven't had success with, is getting it to hide all columns or doing an autofilter based on header value, but as mentioned above, I need it to be a relative value, as the 'X_Top' Changes, and the number of columns also changes. That complicates making an auto filter with a relative Field, I would need it to search through all the columns, which changes based on the project.

[Baiano42]

So I'm able to make a little more progress, I'm able to get it to keep the cases of the specific headers I want ("A" & "Top"). However, I'm still having a problem with keeping the relative headers that change with different reports ("X" being the variable, and "_Top" being the constant e.g. X_Top).

    Dim currentColumn As Integer    Dim columnHeading As String


    For currentColumn = ActiveSheet.UsedRange.Columns.count To 1 Step -1


        columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value


        'CHECK WHETHER TO KEEP THE COLUMN
        Select Case columnHeading
            Case "A", "Top"
                'Do nothing
            Case Else
                'Delete if the cell doesn't contain "Homer"
                If InStr(1, "Top") = 0 Then


                    ActiveSheet.Columns(currentColumn).Delete


                End If
        End Select
    Next

[jolivanes]

Try this.
Check references and change if and where required.

Sub Maybe()
Dim c As Range
    For Each c In Range(Cells(1, 1), Cells(1, Cells(Columns.Count).End(xlToLeft).Column))
        If c.Value Like "*Top*" Then c.EntireColumn.Copy Sheets("Sheet2").Cells(1, Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column + 1)
    Next c
End Sub

[Baiano42]

That works great! Thank you sir!

[jolivanes]

Thank you for letting us know.
Good Luck