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 8
K BAsked:
Who is Participating?
 
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.