重新组织Excel工作表，一列到多列[重复]

Question

我对堆栈溢出还很陌生，但我以前一直在这里作为一个潜伏者。 所以我在重新组织这个excel输出时遇到了麻烦。原始输出如下。我已经修改了输出以保护数据集的机密性，并且为了节省时间，因为数据集有超过 10k 个单元格，但想法应该很清楚。 Before

如您所见，有很多重复和无用的东西，而且通常是烦人的地方。基本上我需要将数据重新组织到列标题中并重新填充电子表格，以便数据保持正确的代码编号。当前的超类别和子类别的列标题毫无价值。我在这里附上了我认为最理想的东西。 After

我尝试过使用数据透视表，这种方法可以起到一半的作用，但这仍然需要我检查输出并手动复制和粘贴 2 个多小时。我也尝试在 excel 中使用转置，虽然这对问题的第一部分有好处，可以制作新的列标题，但它并不能解决重新填充电子表格和保持一切正常的问题。

非常感谢。

Answer 1

在不了解更多信息的情况下，以下代码适用于我使用图片中提供的数据进行测试。当然，最大的问题是 After 数据中的列标题来自哪里。它似乎来自之前数据的 B 列。我假设这些对于列 A 中的每个唯一值都会重复。因此，在下面的代码中，只有第一组值用于设置新创建的工作表的标题。

Option Explicit

Sub TransposeWithUniques()

    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim Uniques As Collection
    Dim Unique As Variant
    Dim UniqueData() As Variant
    Dim FormulaColumn As Range
    Dim CriteriaColumn As Range
    Dim DataRange As Range
    Dim FoundRange As Range
    Dim ValueIndex As Long
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim NewRow As Long
    Dim ErrorFound As Boolean

    Set SourceSheet = ActiveSheet '!!! This will need to be the currently active sheet housing your data

    ' If sheet is protected, exit
    If SourceSheet.ProtectContents Then
        MsgBox "Please unprotect the worksheet first.", vbExclamation, "Transpose with Uniques"
        Exit Sub
    End If

    ' Get last row/column
    LastRow = SourceSheet.Cells(SourceSheet.Rows.Count, 1).End(xlUp).Row
    LastColumn = SourceSheet.Cells(1, SourceSheet.Columns.Count).End(xlToLeft).Column
    Set DataRange = SourceSheet.Range("A1", SourceSheet.Cells(LastRow, LastColumn))
    NewRow = 1

    ' Get unique UniqueData from column A
    UniqueData = SourceSheet.Range("A2:A" & LastRow).Value2
    Set Uniques = New Collection
    For ValueIndex = LBound(UniqueData, 1) To UBound(UniqueData, 1)
        If InCollection(Uniques, CStr(UniqueData(ValueIndex, 1))) = False Then
            Uniques.Add UniqueData(ValueIndex, 1), CStr(UniqueData(ValueIndex, 1))
        End If
    Next ValueIndex

    ' Set application properties for better code running experience
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    ' Add helper columns
    On Error GoTo TransposeWithUniques_Error
    SourceSheet.Cells(1, LastColumn).Offset(0, 1).Resize(LastRow, 2).Insert
    Set CriteriaColumn = SourceSheet.Cells(1, LastColumn).Offset(0, 1).Resize(LastRow, 1)
    Set FormulaColumn = SourceSheet.Cells(1, LastColumn).Offset(0, 2).Resize(LastRow, 1)
    FormulaColumn(1, 1).Value = "FORMULA"
    CriteriaColumn(1, 1).Value = "CRITERIA"
    FormulaColumn(2, 1).Resize(LastRow - 1, 1).Formula = "=ROW(A1)"
    FormulaColumn(2, 1).Resize(LastRow - 1, 1).Value = FormulaColumn(2, 1).Resize(LastRow - 1, 1).Value

    ' Loop through all uniques, get data and move it
    For Each Unique In Uniques
        CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Formula = "=1/(A2=" & Chr(34) & Unique & Chr(34) & ")"
        CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Value = CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Value
        DataRange.Resize(, DataRange.Columns.Count + 2).Sort Key1:=CriteriaColumn(1, 1), Order1:=xlAscending, Key2:=SourceSheet.Range("B1"), Order2:=xlAscending, Header:=xlYes
        On Error Resume Next
        Set FoundRange = CriteriaColumn.SpecialCells(xlCellTypeConstants, xlNumbers)
        On Error GoTo 0
        If Not FoundRange Is Nothing Then
            If TargetSheet Is Nothing Then
                Set TargetSheet = ActiveWorkbook.Worksheets.Add(After:=SourceSheet)
                TargetSheet.Range("A1").Value = SourceSheet.Range("A1").Value
                TargetSheet.Range("B1").Resize(1, FoundRange.Cells.Count).Value = Application.Transpose(Intersect(SourceSheet.Range("B:B"), FoundRange.EntireRow).Value)
            End If
            NewRow = NewRow + 1
            TargetSheet.Cells(NewRow, 1).Value = Unique
            TargetSheet.Cells(NewRow, 2).Resize(1, FoundRange.Cells.Count).Value = Application.Transpose(Intersect(SourceSheet.Range("C:C"), FoundRange.EntireRow).Value)
            Set FoundRange = Nothing
        End If
    Next Unique


    ' Reset data to original state
    DataRange.Resize(, DataRange.Columns.Count + 2).Sort Key1:=FormulaColumn(1, 1), Order1:=xlAscending, Header:=xlYes
    FormulaColumn.Delete xlToLeft
    CriteriaColumn.Delete xlToLeft

TransposeWithUniques_Exit:
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    If Not ErrorFound Then
        MsgBox "Process completed successfully.", vbInformation, "Transpose with Uniques"
    End If
    Exit Sub

TransposeWithUniques_Error:
    ErrorFound = True
    MsgBox "Something went wrong.", vbExclamation, "Transpose with Uniques"
    GoTo TransposeWithUniques_Exit

End Sub


Public Function InCollection(CheckCollection As Collection, CheckKey As String) As Boolean
'
' Returns True if the specified key is found in the specified collection.
'
' Syntax:       InCollection(CheckCollection,CheckKey)
'
' Parameters:   CheckCollection. Collection. Required. The collection to search in.
'               CheckKey. String. Required. The string key to search in collection for.
'
    On Error Resume Next
    InCollection = CBool(Not IsEmpty(CheckCollection(CheckKey)))
    On Error GoTo 0

End Function

要使用上面的代码，在您要运行它的文件中，按 ALT+F11 打开 Visual Basic 编辑器 (VBE)。按 CTRL+R 显示项目资源管理器 (PE)，通常默认显示。在 PE 中找到您的项目并右键单击它，选择插入、模块。双击新插入的模块（应命名为Module1）。将上述代码复制/粘贴到此模块中。单击顶部例程内的任意位置（例如，单击顶部“TransposeWithUniques”附近的文本，使您的光标位于该行上，或就在其下方）。按 F5 运行例程。

注意：确保在运行之前保存文件的备份副本。它将数据重置为其原始状态，但这始终是一种好习惯。检查新创建的工作表以确保它是您要查找的内容。如果这不是您要查找的内容，请在解释输入与输出时尽可能具体。

问候， 扎克·巴雷斯