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]

Try this macro:

Public Sub Merge_xls_Sheets()

    Dim xlsFile As Variant
    Dim xlsWb As Workbook
    Dim xlsxWb As Workbook
    Dim ws As Worksheet
    Dim destCell As Range
    
    xlsFile = Application.GetOpenFilename(Title:="Select .xls file", FileFilter:="Excel 97-2003 workbook (*.xls), *.xls")
    If xlsFile = False Then Exit Sub
    
    Set xlsxWb = Workbooks.Add(xlWBATWorksheet)
    Set destCell = xlsxWb.Worksheets(1).Range("A1")
    
    Set xlsWb = Workbooks.Open(xlsFile)
    For Each ws In xlsWb.Worksheets
        ws.UsedRange.Copy destCell
        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, Replace(xlsFile, ".xls", ".xlsx")
    Application.DisplayAlerts = True
    
End Sub

 

[doriannjeshi]

I get this

 

[John_w]

Try this macro instead:

Public Sub Merge_xls_Sheets()

    Dim xlsFile As Variant
    Dim xlsWb As Workbook
    Dim xlsxWb As Workbook
    Dim ws As Worksheet
    Dim destCell As Range
    
    xlsFile = Application.GetOpenFilename(Title:="Select .xls file", FileFilter:="Excel 97-2003 workbook (*.xls), *.xls")
    If xlsFile = False Then Exit Sub
    
    Set xlsxWb = Workbooks.Add(xlWBATWorksheet)
    Set destCell = xlsxWb.Worksheets(1).Range("A1")
    
    Set xlsWb = Workbooks.Open(xlsFile)
    For Each ws In xlsWb.Worksheets
        ws.UsedRange.Copy
        destCell.PasteSpecial
        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, Replace(xlsFile, ".xls", ".xlsx")
    Application.DisplayAlerts = True
    
End Sub

 

[doriannjeshi]

I get this again

 

[jolivanes]

Using John's suggestion, if you change this part

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

to this

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

Does it work then?

 

[John_w]

I get this again

View attachment 118845

I can't reproduce the error. Could you upload a copy of your .xls file to a file sharing site (Dropbox, Google Drive, OneDrive, etc) and I'll fix my code.

 

[doriannjeshi]

I can't reproduce the error. Could you upload a copy of your .xls file to a file sharing site (Dropbox, Google Drive, OneDrive, etc) and I'll fix my code.

demo.XLS

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

 

[doriannjeshi]

Using John's suggestion, if you change this part

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

to this

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

Does it work then?

 

[jolivanes]

Delete the period(.)