Debug my loop!

The attached code works perfectly for the first sheet, but on the second i get error "1004: Method 'Range' of object'_Worksheet' failed". I've attached an example of what the data looks like that i'm working with. We have a spreadsheet for every customer. I'm trying to copy the information into one spreadsheet in a database format. Since the customers may be located in different locations i'm trying to separate the information between the three regions.

Sub Compile2()


    Dim sh As Worksheet
    Dim UKsh As Worksheet
    Dim EUsh As Worksheet
    Dim USsh As Worksheet
    Dim EUrow As Long, UKrow As Long, USrow As Long
    Dim FinNum As Integer

    EUrow = 2
    UKrow = 2
    USrow = 2

Set UKsh = Sheets("UK")
Set EUsh = Sheets("EU")
Set USsh = Sheets("US")


For Each sh In Worksheets
    With sh
    FinNum = 3
        Do
            If .Range("A60").Value = "EU" Then
                .Range("B5").Copy
                EUsh.Range("A" & EUrow).PasteSpecial Transpose:=True
                .Range(Cells(8, FinNum), Cells(48, FinNum)).Copy
                EUsh.Range("B" & EUrow).PasteSpecial Transpose:=True
                EUrow = EUrow + 1
            ElseIf .Range("A60").Value = "UK" Then
                .Range("B5").Copy
                UKsh.Range("A" & UKrow).PasteSpecial Transpose:=True
                .Range(Cells(8, FinNum), Cells(48, FinNum)).Copy
                UKsh.Range("B" & UKrow).PasteSpecial Transpose:=True
                UKrow = UKrow + 1
            Else
                .Range("B5").Copy
                USsh.Range("A" & USrow).PasteSpecial Transpose:=True
                .Range(Cells(8, FinNum), Cells(48, FinNum)).Copy
                USsh.Range("B" & USrow).PasteSpecial Transpose:=True
                USrow = USrow + 1
            End If
            FinNum = FinNum + 1
         Do Until FinNum > 7
    Application.CutCopyMode = False
    End With
Next
End Sub

Compile example.xlsm

Edit: I just tested it again, and now it is saying that I have a compile error "End With without With". So I have even more problems

Try:

Loop Until FinNum > 7

I'll look at the first problem but to solve the second problem change "Do Until" to "Loop Until".

You're welcome and thanks for the rep

Maybe:

Sub Compile2()

    Dim N As String
    Dim sh As Worksheet
    Dim UKsh As Worksheet
    Dim EUsh As Worksheet
    Dim USsh As Worksheet
    Dim EUrow As Long, UKrow As Long, USrow As Long
    Dim FinNum As Integer

    EUrow = 2
    UKrow = 2
    USrow = 2

Set UKsh = Sheets("UK")
Set EUsh = Sheets("EU")
Set USsh = Sheets("US")


For Each sh In Worksheets: N = sh.Name
If N Like "Client*" Then
    With sh
        FinNum = 3
        Do
            If .Range("A60").Value = "EU" Then
                .Range("B5").Copy
                EUsh.Range("A" & EUrow).PasteSpecial xlPasteAll
                .Range(.Cells(8, FinNum), .Cells(48, FinNum)).Copy
                EUsh.Range("B" & EUrow).PasteSpecial Transpose:=True
                EUrow = EUrow + 1
            ElseIf .Range("A60").Value = "UK" Then
                .Range("B5").Copy
                UKsh.Range("A" & UKrow).PasteSpecial xlPasteAll
                .Range(.Cells(8, FinNum), .Cells(48, FinNum)).Copy
                UKsh.Range("B" & UKrow).PasteSpecial Transpose:=True
                UKrow = UKrow + 1
            Else
                .Range("B5").Copy
                USsh.Range("A" & USrow).PasteSpecial xlPasteAll
                .Range(.Cells(8, FinNum), .Cells(48, FinNum)).Copy
                USsh.Range("B" & USrow).PasteSpecial Transpose:=True
                USrow = USrow + 1
            End If
            FinNum = FinNum + 1
         Loop Until FinNum > 7
        Application.CutCopyMode = False
    End With: End If
Next
End Sub