Excel Workbooks with single tabs, consolidate columns A & D into one long column in a workbook

Start with multiple source workbooks, single tabs.
Grab column A & D data from each source workbook.
Create one target workbook with the data from source workbook's A & D
However, in target workbook use Column A & B for all data.... two long columns of data.
Thank you!!

K.B.
LVL 9
K BAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
This might need a little tweaking for your data.
Option Explicit


Sub CombineData()
    Dim oWbk As Workbook
    Dim rRng As Range, rToCopy As Range, rNextCl As Range
    Dim iCol As Integer, iCol2 As Integer
    Dim iX As Integer
    Dim bHeaders As Boolean
    Dim sFil As String
    Dim sPath As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        '   On Error GoTo exithandler
        ' assumes workbooks are in a sub folder named "Data"
        sPath = ThisWorkbook.Path & Application.PathSeparator & "Data"
        ChDir sPath
        sFil = Dir("*.xl*")    'change or add file formats e.g. Dir("*.xlsx")
        Do While sFil <> ""    'will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets(1)
                Set rRng = .Range("A1").CurrentRegion
                If rRng.Cells.Count = 0 Then
                    'no data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If
            End With
            Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
            'A1 must be within the data, if not amend the Range below
            With oWbk.ActiveSheet
                For iX = 1 To 2
                    iCol = Choose(iX, 1, 4)
                    Set rToCopy = .Range(.Cells(1, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
                    If Not bHeaders Then
                        If iX = 1 Then
                            iCol2 = 1
                        Else: iCol2 = 2
                        End If
                        Set rNextCl = ThisWorkbook.Worksheets(1).Cells(1, iCol2).End(xlUp).Offset(1)
                        bHeaders = True
                    Else:
                        'headers exist so don't copy
                        Set rToCopy = rToCopy.Offset(1)
                    End If
                    rToCopy.Copy rNextCl
                Next iX
            End With

            oWbk.Close False     'close source workbook
            sFil = Dir
        Loop    ' End of LOOP
        'sort to remove empty rows
        Set rRng = ThisWorkbook.Worksheets(1).UsedRange
        rRng.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                  DataOption1:=xlSortNormal
exithandler:
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.