Copy/Paste Multiple Dynamic Ranges below each other

Hello All,

Could use some help with a macro. I have a workbook with 30+ worksheets. Each worksheet has a range of values, the columns are always the same but the number of rows are different for each sheet - hence dynamic range. What I need is a macro something like that:

- Go to Sheet 1
- Copy Range in Sheet 1 (currSheet)
- Paste in Sheet named "Query"
- Go to Sheet 2
- Copy Range in Sheet 2 (currSheet)
- Paste in Sheet "Query" BELOW the previous range that was pasted
---Rinse & Repeat for all worksheets in workbook----

So basically I would be making a list of the ranges in a sense (if that makes sense)

I get a "Subscript Out of Range" error at the copy/paste code line:

Worksheets(currSheet).Range("F2:H" & LastRow).Copy Destination:=Worksheets("Query").Cells(Rows.Count, "A").End(xlUp).Offset(1)

Prior to this line I have some code that loops through and does some formatting stuff on all sheets

Any advice/help would be much appreciated.

Can't seem to attach the workbook...is there a size limit on uploads?

Cheers.

Here is the full code. Let me know if you need the workbook.:

Option Explicit
Sub datechange()

Dim currSheet As Variant
Dim allSheets() As Variant
Dim LastRow As Integer
Dim i As Integer
Dim k As Integer
Dim fmt As String
Dim var As String
Dim well As String

Application.ScreenUpdating = False

allSheets = Sheets("Tags").Range("M3:M33").Value
    For Each currSheet In allSheets
        LastRow = Worksheets(currSheet).Cells(Rows.Count, 2).End(xlUp).Row
        Worksheets(currSheet).Select
            For i = 2 To LastRow Step 1
             If Cells(i, 3) = "Null" Then
                Cells(i, 3) = -9999.97
            End If
                fmt = "0."
                
                For k = 1 To Len(Cells(i, 3)) - 2
                    fmt = fmt & "0"
                Next
                
                If Len(Cells(i, 3)) = 1 Then fmt = "0"
                    If i = LastRow Then
                        Cells(i, 6) = "UPDATE Table_Name SET [" & Cells(1, 6) & "]='" & Format(Cells(i, 3), fmt) & "' Where TimeStamp >= '" & Format(Cells(i, 2), "mm/dd/yyyy hh:mm:ss") & "'  and TimeStamp < '01/23/2015 07:30:00'"
                    Else
                        Cells(i, 6) = "UPDATE Table_Name SET [" & Cells(1, 6) & "]='" & Format(Cells(i, 3), fmt) & "' Where TimeStamp >= '" & Format(Cells(i, 2), "mm/dd/yyyy hh:mm:ss") & "'  and TimeStamp < '" & Format(Cells(i + 1, 2), "mm/dd/yyyy hh:mm:ss") & "'"
                End If
                
                If InStr(Cells(1, 7), "Manifold") Then
                    well = "M01-M07"
                        If InStr(Cells(1, 7), "DPMeas") Then
                                var = "Meas DP"
                            ElseIf InStr(Cells(1, 7), "OutletPressureMeas") Then var = "Outlet Press Meas"
                            ElseIf InStr(Cells(1, 7), "OutletTemperatureMeas") Then var = "Outlet Temp Meas"
                            Else
                                var = "Gas Volume Rate Meas"
                        End If
                ElseIf InStr(Cells(1, 7), "AM-C1DToAM-A1D") Then
                    well = "C1D to A1D"
                        If Right(Cells(1, 7), 1) = 1 Then
                            var = "Valve Position1"
                        Else
                            var = "Valve Position0"
                        End If
                Else
                    well = "Well " & Mid(Cells(1, 7), 25, 3)
                        If InStr(Cells(1, 3), "_P") Then
                            var = "PBC"
                        ElseIf InStr(Cells(1, 3), "_T") Then var = "TBC"
                        ElseIf InStr(Cells(1, 3), "_H") Then var = "Choke"
                        Else
                            var = "Wing Valve"
                        End If
                End If
                    
                Cells(i, 8) = "all"
                Cells(i, 7) = "Correcting " & well & " " & var & " to " & Format(Cells(i, 3), "0.000") & ""
            Next i
        Worksheets(currSheet).Range("F2:H" & LastRow).Copy Destination:=Worksheets("Query").Cells(Rows.Count, "A").End(xlUp).Offset(1)
    Next currSheet

Application.ScreenUpdating = True

End Sub

Originally Posted by :) Sixthsense :)

The full code seems to be ok... but I need a sample file to fix the issue

Is there a cap on the upload file size? The workbook is 2.8MB but won't let me upload...

Genius! Here it is

Where would you Set the current and new workbook? If i put these outside the first For loop, I get an subscript out of range error at the allSheets line, shown below:

Set wCurr = ThisWorkbook
Set wNew = Workbooks.Add
allSheets = Sheets("Tags").Range("M3:M33").Value
    For Each currSheet In allSheets

And I've activated the current and new sheet within the first for loop:

            Next i
        wCurr.Activate
        wNew.Activate
        wCurr.Worksheets(currSheet).Range("F2:H" & LastRow).Copy _
        Destination:=wNew.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
'        Worksheets(currSheet).Range("F2:H" & LastRow).Copy Destination:=Worksheets("Query").Cells(Rows.Count, "A").End(xlUp).Offset(1)
    Next currSheet

Beautiful! Works greats.

Thanks a lot man