Reply to thread

Message

[QUOTE="Turps, post: 14230174, member: 122818"]
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
        [B][COLOR=Red]If sh.Name <> DestSh.Name Then[/COLOR][/B]
        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
[/QUOTE]

Verification