Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

search header loop through in multiple files if matched then copy entire column and paste into single column

0

There are multiple Workbooks in a folder and have similar column which Header name is "Name" but in each file column position is chnaged.

I want to search that header in 1st row of each workbook if finds then copy that entire column from multiple workbooks availble in Folder and Paste Unique result (values) into an open workbook where from code is being run.

There is one more thing that i want to extract multiple column by Header please add Array method so i can add more column name. I have attached 2 workbooks and result file

I would appreciate your help.

Sub MultipleSimilarColinto_1()
 
    Dim xFd         As FileDialog
    Dim xFdItem     As String
    Dim xFileName   As String
    Dim wbk         As Workbook
    Dim sht         As Worksheet
    Dim twb         As Workbook
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim desWS As Worksheet
    Dim colArr As Variant
    Dim order As Long
    Dim i As Long

    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ActiveWindow.View = xlNormalView
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    Set twb = ActiveWorkbook
    Set desWS = twb.Sheets("Sheet1")
    If xFd.Show Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
    Else
        Beep
        Exit Sub
    End If
    xFileName = Dir(xFdItem & "*.xlsx")
    Do While xFileName <> ""
        
        Set wbk = Workbooks.Open(xFdItem & xFileName)
colArr = Array("Name")
        
        For Each ws In wbk.Sheets
            
            If ws.Name <> "Sheet1" Then
            
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            
            For i = LBound(colArr) To UBound(colArr)
                    order = ws.Rows(1).Find("Name", LookIn:=xlValues, lookat:=xlWhole).Column
                    ws.Range(ws.Cells(2, order), ws.Cells(LastRow, order)).Copy desWS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            Next i
        End If
            
        Next ws
        wbk.Close SaveChanges:=True
        xFileName = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Answer
Discuss

Discussion

What's the issue with your code? Have you tried it? Where are you stuck?
don (rep: 1979) Jul 18, '22 at 10:04 pm
|I am stuck on the searching Header looping through the multiple files. this row "LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row" gives me an error.
 this row if mentioned Header is not available in the file then go to next file.
LearningExcel Jul 19, '22 at 5:28 am
Try my answer and let me know if it works.
don (rep: 1979) Jul 19, '22 at 11:34 am
Add to Discussion

Answers

0

If this line is the issue when there is no header row in the file:

LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Then you can surround it with error handling code like this:

On Error Resume Next

LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

On Error GoTo 0

If Not LastRow Is Nothing Then

    ' Code to run if a last row was found.

End If
Discuss

Discussion

Now receiving error on this line type mismatch If Not LastRow Is Nothing Then
LearningExcel Jul 19, '22 at 3:29 pm
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login