Join 3 columns in 1 column Excel using VBA

Question

I have many excel files that have many columns and I wnat to take only 3 columns of each file, that I would like to group and order in another Excel file (reordering and concatenate them) in only consecutive column.

Example (if I had something this):

File1:
A B C ...
1 2 3 ...
6 7 8 ...
9 10 11 ...

File2:
A B C ...
25 26 27 ...
28 29 30 ...
31 32 33 ...

I would like to join them in a JoinFile.xls like this:

File1
2
7
10
3
8
11
1
6
9
File2
26
29
32
27
30
33
25
28
31

Or

2 File1
7 File1
10 File1
3 File1
8 File1
11 File1
1 File1
6 File1
9 File1
26 File2
29 File2
32 File2
27 File2
30 File2
33 File2
25 File2
28 File2
31 File2

The code that I have is this (writed into VBA):

Sub CombinarReportes()
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")
    'change folder path of excel files here
    Set dirObj = mergeObj.Getfolder("Path")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)
        'change "A2" with cell reference of start point for every files here
        'for example "B3:IV" to merge all files start from columns B and rows 3
        'If you're files using more than IV column, change it to the latest column
        'Also change "A" column on "A65536" to the same column as start point
        Range("B2:D" & Range("B11").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(1).Activate
        'Do not change the following column. It's not the same column as above
        Range("B65536").End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        bookList.Close
    Next
End Sub

It "only" join the multiple source files from Path location into a only file, but my problem is that I don't know how to concatenate the file name to the resultant row.

Answer 1

You could use this code (maybe you'll need to adapt some parts to fix your positions)

Sub CombinarReportes()
Dim bookList As Workbook
Dim WBFinal As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim Ruta As String
Dim UF As Long
Dim WK As Worksheet
Dim MiMatriz As Variant
Dim ZZ As Long, i As Long, XX As Long
Dim MatrizColumnas As Variant



Application.ScreenUpdating = False

Ruta = "D:\Temp\Excel Files" 'change folder path of excel files here

Set mergeObj = CreateObject("Scripting.FileSystemObject")

Set dirObj = mergeObj.Getfolder(Ruta)
Set filesObj = dirObj.Files

ReDim MiMatriz(0 To 0) As Variant 'this is just to initialize array

MatrizColumnas = Array("B", "C", "A") 'make this array the columns you want, and also what order


For Each everyObj In filesObj
    Set bookList = Workbooks.Open(everyObj, , True)
    Set WK = bookList.ActiveSheet
    
    'this code supose the worokbook opens in the worksheet with the values you want
    'also, it thinks values start at row 1
    
    For XX = 0 To UBound(MatrizColumnas) Step 1
        UF = WK.Range(MatrizColumnas(XX) & WK.Rows.Count).End(xlUp).Row
        ZZ = UBound(MiMatriz) 'last index before adding new values
        ReDim Preserve MiMatriz(0 To ZZ + UF) As Variant
        For i = 1 To UF Step 1
            ZZ = ZZ + 1
            MiMatriz(ZZ) = WK.Range(MatrizColumnas(XX) & i).Value & "||" & bookList.Name
        Next i
    Next XX
    
    Set WK = Nothing
    bookList.Close False
    Set bookList = Nothing
    DoEvents
Next

Erase MatrizColumnas

'dump data into final workbook
Set WBFinal = Application.Workbooks.Add
Set WK = WBFinal.ActiveSheet

For i = 1 To UBound(MiMatriz) Step 1
    WK.Range("A" & i).Value = Split(MiMatriz(i), "||")(0)
    WK.Range("B" & i).Value = Split(MiMatriz(i), "||")(1)
Next i
Erase MiMatriz
Set WBFinal = Nothing

Set filesObj = Nothing
Set dirObj = Nothing
Set mergeObj = Nothing


Application.ScreenUpdating = True
End Sub

I made a test with 2 files and it worked perfectly.

Note that the path of files will check every single file on the folder, so make sure it contains only the files you need, or it may fail.

Answer 2

The code below is intended as guide rather than a solution. I only tested the marked section in its middle on a single workbook. The point is that you have a structure here which is comparatively easy to modify to better suit your needs.

Sub CombinarReportes()
    ' 129

    Dim mergeObj    As Object                   ' File System
    Dim dirObj      As Object                   ' folder
    Dim filesObj    As Object                   ' list of files
    Dim everyObj    As Object                   ' loop object: file name
    Dim bookList    As Workbook                 ' loop object: current workbook
    Dim Arr         As Variant                  ' data to be copied
    Dim C           As Long                     ' Column
    Dim R           As Long                     ' Row
    Dim Output      As Variant                  ' data to be pasted
    Dim i           As Long                     ' index to Output()
    
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")
    'change folder path of excel files here
    Set dirObj = mergeObj.Getfolder("Path")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        ' === start of tested code ====
        Set bookList = Workbooks.Open(everyObj)
        With bookList.Worksheets(1)             ' your code doesn't specify a tab
            ' note the last used column in row 2
            C = .Cells(2, .Columns.Count).End(xlToLeft).Column
            ' note last used row in column A
            R = .Cells(.Rows.Count, "A").End(xlUp).Row
            ' note all cell values from B3 down and to the right
            Arr = .Cells(3, "B").Resize(R - 2, C - 1).Value
            bookList.Close SaveChanges:=False
        End With
        
        ReDim Output(1 To UBound(Arr) * UBound(Arr, 2))
        For R = 1 To UBound(Arr)
            For C = 1 To UBound(Arr, 2)
                i = i + 1
                Output(i) = Arr(R, C)
            Next C
        Next R
        
        With ThisWorkbook.Worksheets(1)
            .Cells(.Rows.Count, "A").End(xlUp) _
                   .Offset(2) _
                   .Resize(UBound(Output)) _
                   .Value = Application.Transpose(Output)
        End With
        ' === end of tested code ====
    Next everyObj
    Application.ScreenUpdating = True
End Sub

To explain the method, the code picks the range from which to copy data and reads the data from that range into an array. The source workbook is then closed. In memory the array is converted to another array, arranging everything vertically. Finally, that array is pasted to the target worksheet.

I doubt that I got the source range right. Your descriptions seem to be contradictory. But it's easy to change the range selection to copy from.

The data are transferred to a single vector array. That is the place in the code where you could add a second column. In your code there is no provision for a file number and I haven't added one but the required change would, again, be quite easy.