Merge sheets of a workbook macro

[doriannjeshi]

Hi,

I have an .xls file that is exported and depending on the data it might have 1 sheet to 5 or more . If it was an .xslx file it would be in one sheet but .xls file the data gets divided in 65536 rows per sheet
Is it possible to have a macro that copies all data from all the sheets and paste it in a single sheet on a new workbook .xlsx

 

[John_w]

That was quite tricky. I couldn't get Copy and Paste whole worksheets to work, so instead the macro below copies each xls sheet's values to an array and then assigns the array to the destination cell, resized to the same size as the array.

Public Sub Merge_xls_Sheets3()

    Dim xlsFile As Variant
    Dim xlsxFile As String
    Dim xlsWb As Workbook
    Dim xlsxWb As Workbook
    Dim ws As Worksheet
    Dim destCell As Range
    Dim data As Variant
  
    xlsFile = Application.GetOpenFilename(Title:="Select .xls file", FileFilter:="Excel 97-2003 workbook (*.xls), *.xls")
    If xlsFile = False Then Exit Sub
    xlsxFile = Replace(xlsFile, ".xls", ".xlsx", Compare:=vbTextCompare)
  
    Application.ScreenUpdating = False
  
    Set xlsxWb = Workbooks.Add(xlWBATWorksheet)
    Set destCell = xlsxWb.Worksheets(1).Range("A1")
  
    Set xlsWb = Workbooks.Open(xlsFile)
    For Each ws In xlsWb.Worksheets
        data = ws.UsedRange.Value
        destCell.Resize(UBound(data), UBound(data, 2)).Value = data
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next
    Application.CutCopyMode = False
    xlsWb.Close False
  
    Application.DisplayAlerts = False
    xlsxWb.Close True, xlsxFile
    Application.DisplayAlerts = True
  
    Application.ScreenUpdating = True
  
    MsgBox "Created " & xlsxFile, vbInformation
  
End Sub

 

[doriannjeshi]

thank you
possible to have the xls file name already set do it opens automatically ?

 

[John_w]

thank you
possible to have the xls file name already set do it opens automatically ?

Replace these 2 lines:

    xlsFile = Application.GetOpenFilename(Title:="Select .xls file", FileFilter:="Excel 97-2003 workbook (*.xls), *.xls")
    If xlsFile = False Then Exit Sub

with:

    xlsFile = "C:\path\to\xls workbook.xls"

 

[Alex Blakenburg]

Delete the period(.)

You need to put the With / End With back or your Rows.Count will use the activesheet and only come up with the 65k.

    For Each ws In xlsWb.Worksheets
        destCell.Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count).Value = ws.UsedRange.Value
        With xlsxWb.Worksheets(1)
            Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next ws

 

[jolivanes]

Thanks Alex. My bad for not going through it all.

 

[Alex Blakenburg]

That was quite tricky. I couldn't get Copy and Paste whole worksheets to work,

Interesting, if the used range in the xls file encompasses all rows, the usedrange address switches to full column referencing. Somehow that full column referencing applies in the paste step, which works for the first paste when you are starting at A1 but not for subsequent pastes., since it pushes you off the edge of the sheet.
@jolivanes's code (with the With statement added) seems to be twice as fast as using the Array method in Post 11.

 

[John_w]

Thanks for your analysis, Alex.

As you say, the ws.UsedRange.Copy destCell approach I used in my first code in post #2 fails when destCell doesn't start at row 1 and UsedRange encompasses all 65536 rows of the xls sheet. The OP's demo.xls file has 65536 data rows in Sheet1 and Sheet2 and 61625 rows in Sheet3. As posted, the code successfully copies Sheet1's UsedRange to A1 in the destination sheet, but fails when attempting to copy Sheet2's UsedRange to A65537. If the initial destination cell is set to A2, it fails with Sheet1. The error occurs despite the xlsx destination sheet having a maximum of 1048576 rows.

Neither of the 2 fixes suggested in the error message work.

        'Attempted fix 1: select just one cell in paste area - but same error occurs
        destCell.Worksheet.Activate
        destCell.Select
        ws.UsedRange.Copy destCell

        'Attempted fix 2: paste area same size as copy area - but same error occurs
        ws.UsedRange.Copy destCell.Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count)

It's really quite odd that Excel can't copy 65536 rows when the destination cell isn't on row 1!

Jolivane's method of assigning the source range values to the destination range values - destCell.Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count).Value = ws.UsedRange.Value - works well, although I found it slightly slower than my array method (8.7 seconds versus 8.3 seconds). Both methods are fine if you only want to copy cell values, but not if you also want to copy cell formatting, in which case a modified version of the 'sourceRange.Copy destinationRange' method in post #2 must be used.

In pseudo code, the changes are:

If sourceSheet.UsedRange is exactly 65536 rows Then
  Copy UsedRange, less its last row, to destination cell, resized to same size
  Copy last row of UsedRange to next destination cell
Else
  Copy UsedRange to destination cell, resized to same size
End If

Public Sub Merge_xls_Sheets_Copy_Destination()

    Dim xlsFile As Variant
    Dim xlsxFile As String
    Dim xlsWb As Workbook
    Dim xlsxWb As Workbook
    Dim ws As Worksheet
    Dim destCell As Range, destRange As Range
    Dim ur As Range
    
    xlsFile = "C:\path\to\demo.xls"    
    xlsxFile = Replace(xlsFile, ".xls", ".xlsx", Compare:=vbTextCompare)
    
    Application.ScreenUpdating = False
    
    Set xlsxWb = Workbooks.Add(xlWBATWorksheet)
    Set destCell = xlsxWb.Worksheets(1).Range("A1")
    
    Set xlsWb = Workbooks.Open(xlsFile)
    For Each ws In xlsWb.Worksheets
        Set ur = ws.UsedRange
        Debug.Print ws.Name
        Debug.Print ur.Address, ur.Row & " to " & ur.Row + ur.Rows.Count - 1, ur.Rows.Count & " rows"
        If ur.Rows.Count = 65536 Then
            Set ur = ur.Resize(ur.Rows.Count - 1)
            Set destRange = destCell.Resize(ur.Rows.Count, ur.Columns.Count).Offset(ur.Row - 1, 1)
            Debug.Print "Copy " & ur.Address & " to " & destRange.Address
            ur.Copy destRange
            Set destRange = destCell.Resize(1, ur.Columns.Count).Offset(ur.Row - 1 + ur.Rows.Count, ur.Column - 1)
            Debug.Print "Copy " & ur.Resize(1).Offset(ur.Rows.Count).Address & " to " & destRange.Address
            ur.Resize(1).Offset(ur.Rows.Count).Copy destRange
        Else
            Set destRange = destCell.Resize(ur.Rows.Count, ur.Columns.Count)
            Debug.Print "Copy " & ur.Address & " to " & destRange.Address
            ur.Copy destCell.Resize(ur.Rows.Count, ur.Columns.Count)
        End If
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next
    xlsWb.Close False
    
    Application.DisplayAlerts = False
    xlsxWb.Close True, xlsxFile
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
End Sub

Note - the code assumes that the source data starts in A1 of each sheet, with no blank rows above or to the left of the data.