Simplify Recorded Macro

[Timjan]

Hi Dear Members,

I have a workbook with ten sheets, one of which is a Total Sheet. I need to extract data from at least eight sheets all from the same range and append it

in the Total Sheet to a different range. I have recorded a macro for one sheet so far but, It does not include Copying to the last row of each required

column in each of the sheets. The Recorded Macro is very basic and cumbersome, and I would like to know if any one would please be so kind as to

guide me in how to shorten the Code. Sample for one sheet shown below. How do I get it short and sweet with all of the other remaining seven

sheets included, and can it be done with the Sheet Index number, or does it have to be via the sheet name? [TABLE] <colgroup><col style="mso-width-source:userset;mso-width-alt:33901;width:695pt" width="927"> </colgroup><tbody>[TR] [TD="class: xl65, width: 927"]' Macro1 Macro[/TD] [/TR] [TR] [TD="class: xl65, width: 927"]'[/TD] [/TR] [TR] [TD="class: xl65, width: 927"][/TD] [/TR] [TR] [TD="class: xl65, width: 927"]'[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Oos").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("Z13:Z15").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.Copy[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Totals").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("B14").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] :=False, Transpose:=False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Application.CutCopyMode = False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("D14").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Oos").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] ActiveWindow.ScrollColumn = 1[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("B13:D15").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.Copy[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Totals").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] :=False, Transpose:=False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Oos").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("N13:N15").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Application.CutCopyMode = False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.Copy[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Totals").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("J14").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] :=False, Transpose:=False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Oos").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("T13:T15").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Application.CutCopyMode = False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.Copy[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Sheets("Totals").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Range("P14").Select[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] :=False, Transpose:=False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"] Application.CutCopyMode = False[/TD] [/TR] [TR] [TD="class: xl65, width: 927"]End Sub[/TD] [/TR] </tbody>[/TABLE] Any help would be appreciated. Thank you for your time and help. <colgroup><col style="mso-width-source:userset;mso-width-alt:33901;width:695pt" width="927"> </colgroup><tbody> </tbody>

<colgroup><col style="mso-width-source:userset;mso-width-alt:33901;width:695pt" width="927"> </colgroup><tbody>
</tbody>

 

[MARK858]

Also need to remove the 2nd "End Sub".

 

[Timjan]

Thank you Fluff!

Should the code then look as follow?

Sub TimjanTest()
    'Dim UsdRws As Long, NxtRw As Long
    Dim shtNames, shtCnt
MySheets = Array("Alpha", "Delta", "Bravo", "Echo", "Papa", "Foxtrot", "November", "Whiskey", "Sierra")
    Application.ScreenUpdating = False

        For Each shtCnt In shtNames

        On Error Resume Next

        With Worksheets(shtCnt)
            UsdRws = .Range("S" & Rows.Count).End(xlUp).Row 'The column to copy from each sheet to "Totals"
            NxtRw = Sheets("Totals").Range("B" & Rows.Count).End(xlUp).Row  'Copy to Row 14 and down In the "Totals" Sheet
            Sheets("Totals").Range("B" & NxtRw).Resize(UsdRws - 12).Value = .Range("Z13:Z" & UsdRws).Value
            Sheets("Totals").Range("D" & NxtRw).Resize(UsdRws - 12).Value = .Range("B13:D" & UsdRws).Value
            Sheets("Totals").Range("J" & NxtRw).Resize(UsdRws - 12).Value = .Range("N13:N" & UsdRws).Value
            Sheets("Totals").Range("P" & NxtRw).Resize(UsdRws - 12).Value = .Range("T13:T" & UsdRws).Value
        End With

        On Error GoTo 0
    Next shtCnt

    Application.ScreenUpdating = True

End Sub

It still gives me the same Error "Type Mismatch" and highlights the line in yellow.

Maybe some setting in the Project References?

 

[Fluff]

You haven't change the name of the array, the three parts I highlighted in post#30 should all be the same name, not two different names.

You've also commented out the first Dim line, you would be best to uncomment it.

 

[Timjan]

Many thanks Fluff,

I have changed the code to as below;

Sub TimjanTest()     Dim UsdRws As Long, NxtRw As Long
    Dim shtNames, shtCnt
shtNames = Array("Alpha", "Delta", "Bravo", "Echo", "Papa", "Foxtrot", "November", "Whiskey", "Sierra")
    Application.ScreenUpdating = False

        For Each shtCnt In shtNames
        On Error Resume Next
        With Worksheets(shtCnt)
            UsdRws = .Range("S" & Rows.Count).End(xlUp).Row 'The column to copy from each sheet to "Totals"
            NxtRw = Sheets("Totals").Range("B" & Rows.Count).End(xlUp).Row  'Copy to Row 14 and down In the "Totals" Sheet
            Sheets("Totals").Range("B" & NxtRw).Resize(UsdRws - 12).Value = .Range("Z13:Z" & UsdRws).Value
            Sheets("Totals").Range("D" & NxtRw).Resize(UsdRws - 12).Value = .Range("B13:D" & UsdRws).Value
            Sheets("Totals").Range("J" & NxtRw).Resize(UsdRws - 12).Value = .Range("N13:N" & UsdRws).Value
            Sheets("Totals").Range("P" & NxtRw).Resize(UsdRws - 12).Value = .Range("T13:T" & UsdRws).Value
        End With

        On Error GoTo 0
    Next shtCnt
    Application.ScreenUpdating = True

End Sub

I have also rebooted my machine, and the code does no longer highlight the "For Each shtCnt In shtNames"

But nothing gets copied over.

Colomn S on the Sheets to copy from Row 13 downwards may have one or more entries, or even with some Sheets Empty. All sheets have at least 3 Rows to be copied to the Totals Sheet.

I am losing it!!! LOL

 

[MARK858]

You're not copying from column S in the code. You are copying from Z, B, C, D, N & T.

 

[Timjan]

Hi Fluff,

EDIT: I found one row copied from "Alpha" in Row 399 of the Totals Sheet and, one line of the "West" sheet below that, which is out of the defined range of the Totals Sheet. The objective is to sart populating the Totals Sheet from Row 14, copying all the sheets in the array.

 

[Fluff]

Firstly make this change

NxtRw = Sheets("Totals").Range("B" & Rows.Count).End(xlUp)[COLOR=#ff0000].Offset(1)[/COLOR].Row

Secondly if it's copying to row 399, that means you have data in B399

 

[Timjan]

@Fluff,

You are sharp. Indeed, Column Z Contains formulas all the way down to list the Sheet name if Column B contains Data. Maybe add a helper column to copy Values from Column Z?
But that would require another loop to run through the array of sheets to accomplish that? Then we Copy from that Helper Column.

Thank you for your continued support guys! I really appreciate it.

 

[Fluff]

It doesn't matter how far down col Z the formulas, you're calculating the last row to copy using column S.

 

[Timjan]

@ Fluff & MARK858,
Thank you sooo MUCH for all your help and time. I finally got it to work.

You guys are great!