Question

我有一个excel文件，其中有很多名为＆＃34; xxA＆＃34;和＆＃34; xxB＆＃34; 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行被复制到名为＆＃34; value＆＃34;的列中。并使用工作表名称中的数字创建两个新列，另一个使用这样的字母创建：

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

我认为这就是你要找的东西。它从工作表中复制数据，并按要求拆分工作表名称。我有硬编码只适用于两位数字和单个字母。你有不适合那种形式的床单吗？如果是这样，我可以修改我的代码！

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

编辑：

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”

希望这有帮助。

Excel使用单独工作表中的列填充行数据

2 个答案: