Loop through range of work sheets copying and transpose paste into 1 worksheet

NORRILLOUS

New Member
Joined
Apr 10, 2014
Messages
36
Office Version
  1. 365
Platform
  1. Windows
I have been trying to expand this macro to work on a larger range of worksheets and I am not sure how. The file is setup to cover shifts and each sheet is a day (imagine 93 tabs that represent 1 month and look like the same form over and over), I am trying to update the file where it is recorded in a single dataset but in order to preserve the old data I need to move it to the dataset. Hence why I wrote the below code.

VBA Code:
Sub CopyOldPasteNew()
'

Worksheets("1 - 3rd").Range("A6:A35").Copy
Worksheets("Press Transposed Data").Range("A1").PasteSpecial Paste:=xlPasteValues, Transpose:=True

Worksheets("1 - 3rd").Range("c6:o35").Copy
Worksheets("Press Transposed Data").Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True

'Sealer Side
Worksheets("1 - 3rd").Range("A36:A64").Copy
Worksheets("Sealer Transposed Data").Range("A1").PasteSpecial Paste:=xlPasteValues, Transpose:=True

Worksheets("1 - 3rd").Range("c36:o64").Copy
Worksheets("Sealer Transposed Data").Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True
End Sub
Well This worked for those three sheets, So I thought to myself Record it as a Macro and see what you missing....

I pretty well came up with the same thing...just a lot more text.

VBA Code:
Sub Macro3()
'
' Macro3 Macro
'

'
    Range("A20").Select
    Sheets("1 - 3rd").Select
    Range("A6:A35").Select
    Selection.Copy
    Sheets("Press Transposed Data").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("1 - 3rd").Select
    Range("C6:O35").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Press Transposed Data").Select
    Range("A21").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.SmallScroll Down:=3
    Sheets("1 - 1st").Select
    ActiveWindow.SmallScroll Down:=-6
    Range("C6:O35").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Press Transposed Data").Select
    Range("A34").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.SmallScroll Down:=12
    Range("A47").Select
    Sheets("1 - 2nd").Select
    Range("C6:O35").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Press Transposed Data").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

End Sub
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
It sounds like a simple VBA loop will help you, but the two codes you've provided are quite different, so it's not clear what you want to copy where. For example, the first code copies from one worksheet into two others, the second copies from three worksheets into one other.

Presumably you have worksheets labelled "1 - 1st", "1 - 2nd" "1- 3rd", "2 - 1st" .... up to "31-3rd?" (i.e. three shifts x max 31 days per month = 93 sheets?)

What data do you need to copy? How many rows will there be and is there a pattern (in the first code above, the first copy is 30 rows, the 2nd is 29 rows. Why? Are these numbers fixed? Will they vary depending on how many data lines there are?)

Where do you want to copy it? To how many sheets? Whereabouts within the sheet?

The more you can define this in pseudo code, the easier it will be for us to write a macro to help. For example, your pseudo-code description might be something like:

Code:
For each worksheet in the 93 sheets "1 - 1st" to "31 - 3rd"
    Copy this specified range to the first blank row in Worksheet("Press Transposed Data")
    Copy this other specified range (specified number of lines?) to the first blank row in Worksheet("Some other sheet")
    etc
 
Upvote 0
It sounds like a simple VBA loop will help you, but the two codes you've provided are quite different, so it's not clear what you want to copy where. For example, the first code copies from one worksheet into two others, the second copies from three worksheets into one other.

Presumably you have worksheets labelled "1 - 1st", "1 - 2nd" "1- 3rd", "2 - 1st" .... up to "31-3rd?" (i.e. three shifts x max 31 days per month = 93 sheets?)

What data do you need to copy? How many rows will there be and is there a pattern (in the first code above, the first copy is 30 rows, the 2nd is 29 rows. Why? Are these numbers fixed? Will they vary depending on how many data lines there are?)

Where do you want to copy it? To how many sheets? Whereabouts within the sheet?

The more you can define this in pseudo code, the easier it will be for us to write a macro to help. For example, your pseudo-code description might be something like:

Code:
For each worksheet in the 93 sheets "1 - 1st" to "31 - 3rd"
    Copy this specified range to the first blank row in Worksheet("Press Transposed Data")
    Copy this other specified range (specified number of lines?) to the first blank row in Worksheet("Some other sheet")
    etc

I am sorry I wasn't trying to cause confusion. eventually I will need to run this script for 2 departments. so my original showed the second department.

You are correct about the way my sheets are named and how many there are and I want to copy from all 93 of the sheets named like "1 - 3rd" to another sheet named "Press Transposed Data".

So my psuedo code would be some thing like this

VBA Code:
For each worksheet in the 93 sheets "1 - 3rd" to "31 - 2nd" 
    Copy this specified range ("C6:O35") to the first blank row in Worksheet("Press Transposed Data")
    Copy this specified other range ("C36:O64") to the first blank row in Worksheet("Sealer Transposed Data")
 
Upvote 0
Perhaps something like this:

VBA Code:
Sub CopyOldPasteNew()

    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, row1 As Long, row2 As Long
        
    Set ws1 = Worksheets("Press Transposed Data")
    Set ws2 = Worksheets("Sealer Transposed Data")
    row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    'Provided these 93 worksheets are sequential ...?
    For i = Worksheets("1 - 1st").Index To Worksheets("31 - 3rd").Index
        With Worksheets(i).Range("C6:O35")
            .Copy ws1.Range("A" & row1)
            row1 = row1 + .Rows.Count
        End With
        With Worksheets(i).Range("C36:O64")
            .Copy ws2.Range("A" & row2)
            row2 = row2 + .Rows.Count
        End With
    Next i

End Sub
 
Upvote 0
I am really not sure what I am doing wrong. I put the script in a module and added a button to it (and linked it). but it's like it does nothing. I also tried adding 2 tabs "START" and "END" to eliminate the confusion with tab names and it still didn't work. I click it and it does nothing. Do I need to add my above code before the "End Sub" in this script? I don't understand where this script pastes the data and transposes it.

VBA Code:
Sub CopyOldPasteNew()

    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, row1 As Long, row2 As Long
       
    Set ws1 = Worksheets("Press Transposed Data")
    Set ws2 = Worksheets("Sealer Transposed Data")
    row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
   
    'Provided these 93 worksheets are sequential ...?
    For i = Worksheets("START").Index To Worksheets("END").Index
        With Worksheets(i).Range("C6:O35")
            .Copy ws1.Range("A" & row1)
            row1 = row1 + .Rows.Count
        End With
        With Worksheets(i).Range("C36:O64")
            .Copy ws2.Range("A" & row2)
            row2 = row2 + .Rows.Count
        End With
    Next i

End Sub
 
Upvote 0
I don't know why your code isn't doing anything. I suggest you put in a breakpoint to:

a) see if it is running, and
b) if it is, step through to test why it's not doing what you expect.

Attached is a dummy workbook based on my understanding of what you're wanting to do. CopyOldPasteNew.xlsm

Sorry, I missed the Transpose bit of the question, so I have slightly modified the code:

VBA Code:
Sub CopyOldPasteNew()

    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, row1 As Long, row2 As Long
        
    Set ws1 = Worksheets("Press Transposed Data")
    Set ws2 = Worksheets("Sealer Transposed Data")
    row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    Application.ScreenUpdating = False
    'Provided these 93 worksheets are sequential ...?
    For i = Worksheets("1 - 1st").Index To Worksheets("31 - 3rd").Index
        With Worksheets(i).Range("C6:O35")
            .Copy
            ws1.Range("A" & row1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            row1 = row1 + .Columns.Count
        End With
        With Worksheets(i).Range("C36:O64")
            .Copy
            ws2.Range("A" & row2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            row2 = row2 + .Columns.Count
        End With
    Next i
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
I just thought about it. you had mentioned that my sheets are sequential. And they are but they run "31 - 2nd" on the left and "1 - 3rd" on the right (Picture below)
1617286903431.png


would that cause it not to work?
 
Upvote 0
I just thought about it. you had mentioned that my sheets are sequential. And they are but they run "31 - 2nd" on the left and "1 - 3rd" on the right (Picture below) View attachment 35748

would that cause it not to work?


I changed
VBA Code:
   For i = Worksheets("1 - 3rd").Index To Worksheets("31 - 2nd").Index
to
VBA Code:
For i = Worksheets("31 - 2nd").Index To Worksheets("1 - 3rd").Index
 
Upvote 0
would that cause it not to work?
Ah yes, that would explain it.

We could loop backwards through the sheets like this:

Code:
Sub Test()

    Dim i As Long, j As Long, k(1 To 3)
    k(2) = -1
    k(3) = 1
    For i = Worksheets("1 - 1st").Index To Worksheets("31 - 1st").Index Step -3
        For j = 1 To 3
            If vbCancel = MsgBox("Now I can do stuff with sheet: " & Sheets(i + k(j)).Name, vbOKCancel) Then Exit Sub
        Next j
    Next i

End Sub
But it's probably safer to refer to the sheets by name (perhaps a higher chance the sheets will inadvertently be re-ordered than accidentally renamed?)

Try:

VBA Code:
Sub CopyOldPasteNew()

    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, j As Long, row1 As Long, row2 As Long
    Dim s(1 To 3) As String
       
    Set ws1 = Worksheets("Press Transposed Data")
    Set ws2 = Worksheets("Sealer Transposed Data")
    row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
    s(1) = " - 1st"
    s(2) = " - 2nd"
    s(3) = " - 3rd"
   
    Application.ScreenUpdating = False
   
    For i = 1 To 31
        For j = 1 To 3
            With Worksheets(i & s(j)).Range("C6:O35")
                .Copy
                ws1.Range("A" & row1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                row1 = row1 + .Columns.Count
            End With
            With Worksheets(i & s(j)).Range("C36:O64")
                .Copy
                ws2.Range("A" & row2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                row2 = row2 + .Columns.Count
            End With
        Next j
    Next i
   
    Application.ScreenUpdating = True

End Sub
 
Upvote 0

Forum statistics

Threads
1,212,938
Messages
6,110,788
Members
448,297
Latest member
carmadgar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top