VBA to consolidate data from multiple worksheets in a single worksheet horizontally

[barcode_11]

Hi, I have a code that I am trying to improve and adopt, however, struggling to merge the values horizontally. It copies perfectly however pastes values on top of the earlier values pasted. Any help to improve the code will be greatly appreciated. Please see the code below.

Sub MergeCSVFiles()

Dim wb As Workbook
Dim wbCSV As Workbook
Dim myPath As String
Dim myFile As Variant
Dim fileType As String
Dim i As Integer
Dim ws As Worksheet
Dim Destws As Worksheet
Dim CopyRng As Range
Dim lastcol As Long
Dim lastrow As Long


 With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Source Folder"
        .AllowMultiSelect = False
        .Show
        myPath = .SelectedItems(1) & "\"
    End With
  fileType = "*.csv*"
  myFile = Dir(myPath & fileType)
 
 Workbooks.Add
 
 ActiveWorkbook.SaveAs Filename:= _
        myPath & "Total Results.xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False


Set wb = Workbooks.Open(myPath & "Total Results.xlsm")


  Do While myFile <> ""
    Worksheets.Add(Before:=Worksheets("Sheet1")).Name = "Image " & i + 1
    
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & myPath & myFile _
            , Destination:=ActiveSheet.Range("$A$1"))
            .Name = myFile
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = True
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
            1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    i = i + 1
    myFile = Dir
    
  Loop




    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("MergedSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    Set Destws = ActiveWorkbook.Worksheets.Add
    Destws.Name = "MergedSheet"
    
    Sheets(1).Activate
    Rows("1:2").Select
    Selection.Copy
    Destws.Activate
    Rows("1:2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> Destws.Name Then
    
    ws.Activate
    With ws
   
    lastrow = 2 + Cells(Rows.Count, "E").End(xlUp).Row
            
    Set CopyRng = ws.Range(ws.Rows("3"), ws.Rows(lastrow))
   
    CopyRng.Copy
    End With
    Destws.Activate
    
    With Destws
    lastcol = Cells("4", Columns.Count).End(xlToLeft).Columns
    With Destws.Cells("4", lastcol + 1)
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
         Application.CutCopyMode = False
    End With
    End With
    
    End If
    
    Next
    
MsgBox "Result Merge Complete"


End Sub

 

[Keebellah]

If you sue the code you have attached, you can see you are always copying the data to the same cell

Destination:=ActiveSheet.Range("$A$1"))

You will need to calculate the next first available cell AFTER you copy and place that address there, so use a variable that goes along with the pasted range

 

[barcode_11]

Thanks, but the code you are referring to is used to create different images (tabs) of separate data files. The issue is with the below line of code that I am not able to rectify:

[COLOR=#333333] For Each ws In ActiveWorkbook.Worksheets[/COLOR]    If ws.Name <> Destws.Name Then
    
    ws.Activate
    With ws
   
    lastrow = 2 + Cells(Rows.Count, "E").End(xlUp).Row
            
    Set CopyRng = ws.Range(ws.Rows("3"), ws.Rows(lastrow))
   
    CopyRng.Copy
    End With
    Destws.Activate
    
    With Destws
    lastcol = Cells("4", Columns.Count).End(xlToLeft).Columns
    With Destws.Cells("4", lastcol + 1)
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
         Application.CutCopyMode = False
    End With [COLOR=#333333]    End With[/COLOR]

 

[Trebor76]

Hi barcode_11

Create a long variable called PasteRow and then use the following to consolidate the tabs into the newly created tab called "MergedSheet":

Set Destws = ActiveWorkbook.Worksheets.Add
    Destws.Name = "MergedSheet"
    
    Sheets(1).Activate
    Rows("1:2").Select
    Selection.Copy
    Destws.Activate
    Rows("1:2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> Destws.Name Then
         
            ws.Activate
            With ws
                lastrow = 2 + Cells(Rows.Count, "E").End(xlUp).Row
                Set CopyRng = ws.Range(ws.Rows("3"), ws.Rows(lastrow))
                CopyRng.Copy
            End With
            Destws.Activate
             
            With Destws
                lastCol = Cells("4", Columns.Count).End(xlToLeft).Columns
                If PasteRow = 0 Then
                    PasteRow = 4 'First paste row. Change to suit.
                Else
                    If WorksheetFunction.CountA(Cells) > 0 Then
                        PasteRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    Else
                        PasteRow = 4 'Paste row if there's no data on the tab. Change to suit.
                    End If
                End If
                With Destws.Cells(PasteRow, lastCol + 1)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End With
        End If
    Next ws
    
    MsgBox "Result Merge Complete"

Regards,

Robert

 

[barcode_11]

Thanks Robert,
Appreciate the help, is there a way to paste the values side ways and not stacked ?

 

[Trebor76]

See if you can incorporate this:

Option Explicit
Sub Macro3()

    Dim Destws As Worksheet
    Dim ws As Worksheet
    Dim lastrow As Long
    Dim lastCol As Long
    Dim CopyRng As Range
    Dim PasteCol As Long
    Dim lngMyCol As Long

    Set Destws = ActiveWorkbook.Worksheets.Add
    Destws.Name = "MergedSheet"
    
    Sheets(1).Activate
    Rows("1:2").Select
    Selection.Copy
    Destws.Activate
    Rows("1:2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> Destws.Name Then
            ws.Activate
            With ws
                If WorksheetFunction.CountA(Cells) > 0 Then
                    lastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                    lastrow = 2 + .Cells(Rows.Count, "E").End(xlUp).Row 'Uses Col. E to set variable - is this reliable?
                    If PasteCol = 0 Then
                        PasteCol = 1 'Default column for first output. Change to suit.
                    Else
                        PasteCol = Destws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
                    End If
                    For lngMyCol = 1 To lastCol
                        Range(ws.Cells(3, lngMyCol), ws.Cells(lastrow, lngMyCol)).Copy
                        With Destws.Cells(3, PasteCol)
                            .PasteSpecial xlPasteValues
                            .PasteSpecial xlPasteFormats
                            Application.CutCopyMode = False
                            PasteCol = PasteCol + 1
                        End With
                    Next lngMyCol
                End If
            End With
        End If
    Next ws
    
    MsgBox "Result Merge Complete"

End Sub

Regards,

Robert

 

[barcode_11]

Thanks again Robert, the code however is pasting values on top of each other, so in the end I am getting values that are same as the last tab it pastes.

 

[Trebor76]

This works for me:

Option Explicit
Sub Macro3()

    Dim Destws As Worksheet
    Dim ws As Worksheet
    Dim lastrow As Long
    Dim lastCol As Long
    Dim PasteCol As Long
    
    'Delete a tab called 'MergedSheet' if it exists
    On Error Resume Next
        Application.DisplayAlerts = False
            Sheets("MergedSheet").Delete
        Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set Destws = ActiveWorkbook.Worksheets.Add
    Destws.Name = "MergedSheet"
    
    Sheets(1).Activate
    Rows("1:2").Select
    Selection.Copy
    Destws.Activate
    Rows("1:2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> Destws.Name Then
            ws.Activate
            With ws
                If WorksheetFunction.CountA(Cells) > 0 Then
                    lastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                    lastrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    If PasteCol = 0 Then
                        PasteCol = 1 'Default column for first output. Change to suit.
                    Else
                        PasteCol = Destws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
                    End If
                    Range(ws.Cells(3, 1), ws.Cells(lastrow, lastCol)).Copy
                    With Destws.Cells(3, PasteCol)
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                    End With
                End If
            End With
        End If
    Next ws
    
    MsgBox "Result Merge Complete"

End Sub

 

[barcode_11]

Hi Robert, thanks so much again for the help. You are a star : )
The above one works wonders !

 

[Trebor76]

Thanks for letting us know and you're welcome