Copy Entire Rows from each sheet and paste it in another column in one column with Sheet name pasted against each field from where its being copied

[ajoshi76]

Hi All,

I have multiple sheet - having data in Row 2 starting from A2 until some columns (some sheets have data till D, some have data till G etc..)
I would like a macro, which would copy the data of Row 2 (All columns having data) from all sheets and paste it transformed in Column A in Sheet "Output"

Output Sheet - Column B to be updated with Sheet name from which the Row 2 has been pasted.

Field Name (Column A)
Sheet Name (Column B)

Sample attached.

Any help much appreciated.

Regards
Ashish

 

[AlanSidman]

Sub Transpose()
    Dim ws As Worksheet
    Dim s As Worksheet
    Set s = Sheets("Output")
    Application.ScreenUpdating = False
    Dim lr As Long, lc As Long
    For Each ws In Worksheets
        If ws.Name <> "Output" Or ws.Name <> "List" Then
            lc = ws.Cells(2, Columns.Count).End(xlToLeft).Column
            'ws.Range(Cells(2, 1), Cells(2, lc)).Copy
            ws.Range("A2").CurrentRegion.Copy
            lr = s.Range("A" & Rows.Count).End(xlUp).Row
            s.Range("A" & lr + 1).PasteSpecial xlPasteValues, , , True
            s.Range("B" & lr + 1) = ws.Name
        End If
    Next ws

    Dim i As Long
    lr = s.Range("A" & Rows.Count).End(xlUp).Row
    For i = 3 To lr
        If s.Range("B" & i) = "" Then s.Range("B" & i) = s.Range("B" & i - 1)
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "complete"
End Sub

 

[AlanSidman]

Just noticed an error in my code

change this line:
If ws.Name <> "Output" Or ws.Name <> "List" Then
to

If ws.Name <> "Output" And ws.Name <> "List" Then

 

[ajoshi76]

Have a small bug - the current Region copy copied my entire data in the sheet not only the 2nd row all columns. Can you please help?

ws.Range("A2").CurrentRegion.Copy (Copied all data from A2 below till the data exists in the sheet).

Require only to copy A2 to Last column in Row 2.

 

[mohadin]

Just Another Option

Sub test()
    Dim sh, out As Worksheet
    Dim i, l As Long
    Set out = Sheets("Output")
    Application.ScreenUpdating = False
    ReDim a(1 To Sheets.Count - 2): ReDim b(1 To UBound(a))
    i = 1
    For Each sh In Worksheets
        If sh.Name <> "Output" And sh.Name <> "List" Then
            b(i) = sh.Name
            a(i) = Application.Transpose(sh.Cells(2, 1).CurrentRegion)
            i = i + 1
        End If
    Next
    With out
        .Cells(1, 1) = "Field Name": .Cells(1, 2) = "Sheet Name"
        For i = 1 To UBound(a)
            .Cells(2 + l, 1).Resize(UBound(a(i))) = a(i)
            .Cells(2 + l, 2).Resize(UBound(a(i))) = b(i)
            l = l + UBound(a(i))
        Next i
    End With
End Sub

 

[ajoshi76]

THanks, It is showing blank rows for Sheet10 in the Output Sheet post macro execution

And it gave me subscript out of range for b(i) as there are 224 sheets to process

 

[mohadin]

Ok
224 sheets including Output sheet & List sheet?
And No other sheets

 

[mohadin]

Hi

ReDim a(1 To Sheets.Count - 2): ReDim b(1 To UBound(a))

Should be

ReDim a(1 To Sheets.Count - 1): ReDim b(1 To UBound(a))

 

[ajoshi76]

Ok
224 sheets including Output sheet & List sheet?
And No other sheets

224 sheets excluding the 2 sheets (List and Output).

 

[mohadin]

Have you checked The file in #8

 

[AlanSidman]

If you had shown a sample that is representative of your actual file, this would not have happened. Lesson for the future: Make sure your sample is representative in the beginning so that we can provide you with a viable solution and not have to try and read your mind. We don't know what you know or have on your workbook unless you show us.

 

[ajoshi76]

Hi

ReDim a(1 To Sheets.Count - 2): ReDim b(1 To UBound(a))

Should be

ReDim a(1 To Sheets.Count - 1): ReDim b(1 To UBound(a))

Let me check the spreadsheet - Still issues with 224 sheets - It says Subscript out of range

 

[ajoshi76]

Have you checked The file in #8

The test macro is picking Row 1 and NOT Row 2 in my workbook.

 

[mohadin]

But in your sample there is only one row
so is it possible to upload the actual sample workbook with Non personal data?

 

[mohadin]

BTW
My code Tested for 32 sheets + Output & hidden list sheet
(the layout in file uploaded in #1)>>Ok

 

[ajoshi76]

Updated random data

 

[ajoshi76]

But in your sample there is only one row
so is it possible to upload the actual sample workbook with Non personal data?

Uploaded how the file looks like

 

[mohadin]

Ok see this one

 

[ajoshi76]

Ok see this one

Thanks - it is not working getting Subscript out of range But if i change -2 to -1 it worked.

 

[ajoshi76]

Apologies to all who helped me on this - Next time onwards will ensure i provide the exact spreadsheet with the problem statement.