Question

我对堆栈溢出很新，但我以前曾作为潜伏者在这里。所以我在重组这个excel输出时遇到了麻烦。原始输出如下。我已经修改了输出以保持数据集的机密性，并且由于数据集超过10k的单元格而且为了时间的利益，但是这些想法应该是清楚的。 Before

正如你所看到的那样，有很多重复和无用的东西，而且一般来说很讨厌。基本上我需要将数据重新组织到列标题中并重新填充电子表格，以便数据保持正确的代码编号。 supercatagory和subcategory的当前列标题毫无价值。我已经附上了我认为理想的东西。 After

我尝试过使用数据透视表，这种情况可以作为一个半尺寸，但仍然需要我通过输出并手动复制和粘贴超过2小时。我也尝试在excel中使用转置，虽然这对问题的第一部分有好处，但是制作新的列标题，但它并没有解决重新填充电子表格并保持一切顺利的问题。

非常感谢你。

Answer 1

在不知情的情况下，下面的代码可以帮助我测试图像中提供的数据。当然，最重要的问题是After数据中的列标题来自何处。它似乎来自Before数据的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以显示Project Explorer（PE），通常默认显示。在PE中找到您的项目并右键单击它，选择Insert，Module。双击新插入的模块（应命名为 Module1 ）。将上述代码复制/粘贴到此模块中。单击顶部例程内的任何位置（例如，单击顶部附近的文本＆＃34; TransposeWithUniques＆＃34;以便光标位于该行上，或者在其下方）。按F5运行例程。

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

此致 Zack Barresse

重新组织Excel工作表，将一列重新组合为多列

1 个答案: