Copy all sheets (sheet1, sheet2 etc to 9) and paste to sheet "Master"

[andymalan]

Hello all, i want to find out if there is a better way to copy from sheets1 through 9 and paste to sheet "master" one sheet below the other. here is the code i have cobbled together which does work but maybe there is a more efficient way?

' select the range to copy and paste to "master"
    Sheets("Sheet9").Select
    Rows("3:68").Select
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet8").Select
    Rows("3:68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet7").Select
    Rows("3:68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet6").Select
    Rows("3:68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet5").Select
    Rows("3:68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet4").Select
    Rows("3:68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet3").Select
    Rows("3:68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    ActiveWindow.SmallScroll Down:=-9
    Sheets("Sheet2").Select
    Rows("3:68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet1").Select
    Rows("15:70").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Master").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Columns("A:F").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


    ActiveWorkbook.Worksheets("Master").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Master").Sort.SortFields.Add2 Key:=Range( _
        "A2:A3734"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Master").Sort
        .SetRange Range("A1:L3734")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Your help will be appreciated, and I will have learned something?
best regards, Andy

 

[footoo]

Thank you Footoo, your code does work, but it is taking longer to execute than the code I already have.
I do appreciate you wanting to help.

Very strange. It should be slightly quicker.

 

[Yongle]

Top and tail your code ike this

Optimise True

your code goes here

Optimise False

and put in same module

Private Sub Optimise(TrueFalse As Boolean)
    With Application
        .ScreenUpdating = Not TrueFalse
        .EnableEvents = Not TrueFalse
        .Calculation = xlCalculationAutomatic
        If TrueFalse Then .Calculation = xlCalculationManual
        MsgBox .ScreenUpdating & .EnableEvents & .Calculation
    End With
End Sub

 

[Yongle]

remove this line (i was using it when I was testing)

MsgBox .ScreenUpdating & .EnableEvents & .Calculation