Ron de Bruin - Merge cells from all worksheets

Jul 17, 2014
Reaction score

I have copied/amended code from Ron's website to copy cells from all worksheets.

The problem I'm having is it isn't copying the data from all the worksheets. I have around 20 worksheets in the workbook I'm working on but the code is only copying from around 6 of the worksheets in to "League Table".

I've highlighted the line which should be looking through every worksheet. Any help would be appreciated.

Sub League()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

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

Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "League Table"

StartRow = 2

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A1:F1").Copy DestSh.Range("A1")
End If

'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)

'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then

'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

ActiveWorkbook.Worksheets("League Table").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("League Table").Sort.SortFields.Add Key:=Range( _
"F1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
With ActiveWorkbook.Worksheets("League Table").Sort
.SetRange Range("A2:F1385")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
End With
End If

End If


Application.GoTo DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=-27

ActiveWindow.SmallScroll Down:=15
ActiveSheet.Buttons.Add(142.5, 519, 126, 31.5).Select
Selection.OnAction = "League"
Selection.Characters.Text = "Refresh"
With Selection.Characters(Start:=1, Length:=7).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
ActiveWindow.SmallScroll Down:=-21

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
On Error GoTo 0
End Function


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question