I have multiple workbooks in a Folder around 8 and there are Similar columns in some of these workbooks.

For Example:

There are 6 Workbooks out of 8 have similar column which Header name is "SouthRecord" 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 appended result into an open workbook where from code is being run.

Code is copeing tha data but getting error on this line LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Object variable and with block variable not set.

If 4 workbooks has Same Header then these 4 column will be pasted into open workbook as single column.

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("MD")
        
        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("MD", 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

CodePudding user response：

Import Columns From Workbooks

Option Explicit

Sub ImportColumns()
    
    ' Source
    Const sFilePattern As String = "*.xlsx"
    Const sExceptionsList As String = "Sheet1" ' comma-separated, no spaces
    Const sHeader As String = "SouthRecord"
    Const sHeaderRow As Long = 1
    ' Destination
    Const dColumn As String = "A"
    
    ' Source
    
    Dim sfd As FileDialog
    Set sfd = Application.FileDialog(msoFileDialogFolderPicker)
    'sfd.InitialFileName = "C:\Test\"
    
    Dim sFolderPath As String
    
    If sfd.Show Then
        sFolderPath = sfd.SelectedItems(1) & Application.PathSeparator
    Else
        'MsgBox "You canceled.", vbExclamation
        Beep
        Exit Sub
    End If
    
    Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
    
    If Len(sFileName) = 0 Then
        'MsgBox "No files found.", vbExclamation
        Beep
        Exit Sub
    End If
    
    Dim sExceptions() As String: sExceptions = Split(sExceptionsList, ",")
    
    ' Destination
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.ActiveSheet ' improve!
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, dColumn).End(xlUp).Offset(1)
    
    ' Loop.
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim shrg As Range
    Dim sData() As Variant
    Dim sfCell As Range
    Dim slCell As Range
    Dim srCount As Long
    Dim wsCount As Long
    
    Do While Len(sFileName) > 0
        Set swb = Workbooks.Open(sFolderPath & sFileName)
        For Each sws In swb.Worksheets
            If IsError(Application.Match(sws.Name, sExceptions, 0)) Then
                Set shrg = sws.Rows(sHeaderRow)
                Set sfCell = shrg.Find(sHeader, shrg.Cells(shrg.Cells.Count), _
                        xlFormulas, xlWhole)
                If Not sfCell Is Nothing Then
                    Set sfCell = sfCell.Offset(1)
                    Set slCell = sfCell _
                        .Resize(sws.Rows.Count - sHeaderRow) _
                        .Find("*", , xlFormulas, , , xlPrevious)
                    If Not slCell Is Nothing Then
                        srCount = slCell.Row - sHeaderRow
                        Set srg = sfCell.Resize(srCount)
                    End If
                End If
                If srCount > 0 Then
                    If srCount = 1 Then
                        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
                    Else
                        sData = srg.Value
                    End If
                    dfCell.Resize(srCount).Value = sData
                    Set dfCell = dfCell.Offset(srCount)
                    wsCount = wsCount   1
                    srCount = 0
                End If
            End If
        Next sws
        swb.Close SaveChanges:=False
        sFileName = Dir
    Loop
                
    ' Save the destination workbook.
    'dwb.Save
                
    Application.ScreenUpdating = True
    
    MsgBox wsCount & " '" & sHeader & "' columns copied.", vbInformation
                
End Sub