Excel 用不同工作表中的列中的数据填充行

Question

我有一个 excel 文件，其中包含许多名为“xxA”和“xxB”的工作表，其中 xx 是连续数字。

每张表格的格式如下：

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

以及最后的一些其他行。 基本上我想创建一个新工作表，其中 D 列的第 2-27 行被复制到一个名为“值”的列，并创建两个新列，其中包含工作表名称中的数字和另一个具有如下字母的列：

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
...

我尝试弄乱数据透视表，但这并没有真正奏效。我不知道如何创建 VBA，所以如果这是唯一的方法，那么任何方向都会很棒。

Answer 1

我认为这就是您要寻找的。它从工作表中复制数据并按要求拆分工作表名称。我将其硬编码为仅适用于两位数和单个字母。您是否有不适合该表格的床单？如果是这样，我可以重新编写我的代码！

原文：

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

编辑：

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

Answer 2

由于您不了解 VBA，因此我不建议您走这条路。您可以使用 Excel 公式实现您想要的一切。

要获取工作表的名称，请使用：

=MID(CELL("filename",A1),FIND("]",CELL("filename",A1))+1,255)

将“A1”替换为对工作表上您想要命名的单元格的引用。

然后使用Left()函数将名称中的“xx”拆分出来，然后使用Right()函数拆分出“A”

希望这会有所帮助。