Extract multiple sheets data into one sheet

Hi John,

Apology for not getting back to you sooner. I am sorry to inform, I was unable to run the updated macro successfully. The updated macro is throwing a "run-time error 1004", when I run it on example workbook file(data_extraction_2). I believe the error is within the first for loop of the code, hence when I run the macro, I get transferred to the 'June' worksheet.

data_extraction3.xlsm
I have attached the same sample data with 'June' sheet showing 'sum formula' values under the 'bs, rm, cm..etc' columns and the rest of the worksheets 'july' & 'aug', have just number values. The macro is attached in the workbook example.

Thank you very much for updating the code in your previous post.

Many thanks for your response and time in solving the issue.

Try:

Sub jun22()
Dim x As String
Dim y As String
Dim z As String
Dim rng As Range
Dim i As Long
Dim ws As Worksheet

Set ws = Sheets("monthly")
ws.Activate
x = ws.Cells(1, "C").Value
y = ws.Cells(1, "D").Value
z = ws.Cells(1, "E").Value
For i = 3 To ws.Range("A" & Rows.count).End(3).Row Step 4
    Set rng = Sheets(x).Rows(1).Find(ws.Range("A" & i).Value, LookIn:=xlValues, Lookat:=xlWhole)
        If Not rng Is Nothing Then
            Sheets(x).Activate
            Cells(2, rng.Column).Select
            Do Until ActiveCell.Value <> ""
                ActiveCell.offset(1).Select
            Loop
            ws.Cells(i, "C").Resize(3).Value = Range(ActiveCell, ActiveCell.offset(3)).Value
        End If
        Set rng = Nothing
    ws.Activate
    Set rng = Sheets(y).Rows(1).Find(ws.Range("A" & i).Value, LookIn:=xlValues, Lookat:=xlWhole)
        If Not rng Is Nothing Then
            Sheets(y).Activate
            Cells(2, rng.Column).Select
            Do Until ActiveCell.Value <> ""
                ActiveCell.offset(1).Select
            Loop
            ws.Cells(i, "D").Resize(3).Value = Range(ActiveCell, ActiveCell.offset(3)).Value

        End If
        Set rng = Nothing
        ws.Activate
    Set rng = Sheets(z).Rows(1).Find(ws.Range("A" & i).Value, LookIn:=xlValues, Lookat:=xlWhole)
        If Not rng Is Nothing Then
            Sheets(z).Activate
            Cells(2, rng.Column).Select
            Do Until ActiveCell.Value <> ""
                ActiveCell.offset(1).Select
            Loop
            ws.Cells(i, "E").Resize(3).Value = Range(ActiveCell, ActiveCell.offset(3)).Value
        End If
        Set rng = Nothing
ws.Activate
Next i

End Sub