Macro

If it isn't finding any Rows it errors. This seems to work

Sub PrepareUpload()
    Dim ws     As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        Application.ScreenUpdating = False
        On Error Resume Next
        Select Case ws.Name
            Case "Journal"    'do nothing
            Case Else
                ws.Select
                Find_Range("Yes", ws.Range("W13:W100")).EntireRow.Select
                Selection.Copy Worksheets("Journal").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End Select
    Next ws
    Application.ScreenUpdating = True
    On Error GoTo 0
End Sub