Ron de Bruin - Merge cells from all worksheets

[Turps]

Hi,

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
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

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

End If
Next

ExitTheSub:

Application.GoTo DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

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

Rows("32:32").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-27
Range("A1").Select

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
Range("B38").Select
ActiveWindow.SmallScroll Down:=-21
Range("A1").Select

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, _
MatchCase:=False).Row
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, _
MatchCase:=False).Column
On Error GoTo 0
End Function