EXCEL VBA Choose a file and search the first row for key words then copy the column to another file

Question

I have the following issue.

I want to choose a folder with multiple .xlsx files in it. Loop through the files and open them. The search the first row for KEYWORDS and if one of those keywords is found. COPY the entire Column full of data to the sheet with the keyowrd as the Name of the sheet and the first Column of every data. ThisWorkbook.Sheet("KEYWORD")

I have the following code, but it is getting complicated for me as an absolute beginner with coding in general.

Sub FINDandCopy()

With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With


    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    Dim NewSh As Worksheet
    Dim SHINDEX As String


File = Application.GetOpenFilename
File_Name = Dir(File)

Workbooks.Open Filename:=File


With ThisWorkbook.Worksheets

       .Add(After:=Sheets(Sheets.Count)).Name = File_Name

End With

    'MyArr = Array("Banana")
    MyArr = Array("I51", "I54", "I55", "I57", "I58")

   Range("A:A").Copy ThisWorkbook.Sheets(File_Name).Range("A:A")

    With Worksheets(1).Rows(1)

        Rcount = 0

        For I = LBound(MyArr) To UBound(MyArr)

            Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)

            If Not Rng Is Nothing Then

                FirstAddress = Rng.Address

                Do

                    Rcount = Rcount + 1
                    Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlDown)).Copy ThisWorkbook.Sheets(File_Name).Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)


                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With

Workbooks(2).Close
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
MsgBox "Complete"
End Sub

My Keywords are found in the Array (I51, ....) and these are part of the header f.e. (I51.RhValue).

The last error has been changed:

From:

Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp))

to

Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlDown))

SOLVED Thanks to SJR!

Thank you Daniel!

Answer 1

Can you give this a try. I assume you want the results pasted across the sheet (in columns) rathen than down (by rows).

You were pretty much there, just need to copy the whole column when the header is found.

Sub FINDandCopy()

Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Dim NewSh As Worksheet

strDatei = Application.GetOpenFilename

If strDatei <> False Then

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

MyArr = Array("I51", "I54", "I55", "I57", "I58")

With Sheets(1).Rows(1) 'shoud add a workbook reference as working with more than one file
    For I = LBound(MyArr) To UBound(MyArr)
        Set Rng = .Find(What:=MyArr(I), _
                        After:=.Cells(.Cells.Count), _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            FirstAddress = Rng.Address
            Do
                Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp)).Copy ThisWorkbook.Sheets(MyArr(I)).Cells(1, columns.Count).end(xltoleft).offset(,1)
                Set Rng = .FindNext(Rng)
            Loop While Rng.Address <> FirstAddress
        End If
    Next I
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub