Excel fill rows with data from columns in separate sheets

Question

I have an excel file with lots of sheets named "xxA" and "xxB" with xx being consecutive numbers.

Each sheet has the following format:

header1      header2      header3      header 4     header5
ingredient1  description  xx           20           g
ingredient2  description  xx           34           ml
ingredient3  description  xx           56           g

and some other rows at the end. Basically I want to create a new sheet in which rows 2-27 from column D are copied to a column named "value" and create two new columns with the number in the sheet name and another one with the letter like so:

subject    condition    ingredient    value
21         A            ingredient1   20
21         A            ingredient2   34
21         A            ingredient3   56
21         B            ingredient1   34
21         B            ingredient2   23
21         B            ingredient3   47
...

I tried messing with pivot tables but that doesn't really work. I don't know how to create a VBA, so any direction on that would be great if that is the only way to go.

PartyHatPanda PartyHatPanda · Accepted Answer · 2016-08-18T13:02:33

I think this is what you are looking for. It copies data from worksheets and gets the sheet names split as asked. I have it hard coded to only work for double digit numbers and single letters. Do you have sheets that do not fit that form? If so, I can rework my code!

ORIGINAL:

Sub SheetSummary()

'Make new worksheet with required headers
ActiveWorkbook.Sheets.Add
ActiveSheet.name = "Summary"
range("A1").Value = "subject"
range("B1").Value = "condition"
range("C1").Value = "ingredient"
range("D1").Value = "value"

Dim ws As Worksheet
Dim wsNum As String
Dim wsLetter As String
Dim wsLastRow As Long
Dim sumLastRow As Long
Dim myCell As range
Dim nextOpenRow As Long

'If a worksheet is not the summary, then get the data
For Each ws In Worksheets
    If ws.name <> "Summary" Then
        wsNum = Left(ws.name, 2)
        wsLetter = Right(ws.name, 1)

        wsLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
        nextOpenRow = Cells(Rows.count, "A").End(xlUp).Row + 1

        ws.range("A2", ws.Cells(wsLastRow, "A")).Copy

        range("C" & nextOpenRow).PasteSpecial xlPasteAll

        lastRow = Cells(Rows.count, "C").End(xlUp).Row

        ws.range("C2", ws.Cells(wsLastRow, "C")).Copy

        range("D" & nextOpenRow).PasteSpecial xlPasteAll

        Application.CutCopyMode = False

        For Each myCell In range("A2", Cells(lastRow, "A"))
            If myCell.Value = "" Then
                myCell.Value = wsNum
            End If
        Next myCell

        For Each myCell In range("B2", Cells(lastRow, "B"))
            If myCell.Value = "" Then
                myCell.Value = wsLetter
            End If
        Next myCell
    End If
Next ws

End Sub

EDIT:

Sub SheetSummary()

'Make new worksheet with required headers
ActiveWorkbook.Sheets.Add
ActiveSheet.name = "Summary"
range("A1").Value = "subject"
range("B1").Value = "condition"
range("C1").Value = "ingredient"
range("D1").Value = "value"

Dim ws As Worksheet
Dim wsNum As String
Dim wsLetter As String
Dim wsLastRow As Long
Dim sumLastRow As Long
Dim myCell As range
Dim nextOpenRow As Long

'If a worksheet is not the summary, then get the data
For Each ws In Worksheets
    If ws.name <> "Summary" Then
        wsNum = Left(ws.name, 2)
        wsLetter = Right(ws.name, 1)

        wsLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
        nextOpenRow = Cells(Rows.count, "A").End(xlUp).Row + 1

        ws.range("A2:A27").Copy

        range("C" & nextOpenRow).PasteSpecial xlPasteAll

        lastRow = Cells(Rows.count, "C").End(xlUp).Row

        ws.range("D2:D27").Copy

        range("D" & nextOpenRow).PasteSpecial xlPasteAll

        Application.CutCopyMode = False

        For Each myCell In range("A2", Cells(lastRow, "A"))
            If myCell.Value = "" Then
                myCell.Value = wsNum
            End If
        Next myCell

        For Each myCell In range("B2", Cells(lastRow, "B"))
            If myCell.Value = "" Then
                myCell.Value = wsLetter
            End If
        Next myCell
    End If
Next ws

End Sub

Excel fill rows with data from columns in separate sheets

2 Answers