VBA Excel棘手的“嵌套”列排序[关闭]答案

【问题标题】：VBA Excel tricky "Nested" Column Sorting [closed]VBA Excel棘手的“嵌套”列排序[关闭]
【发布时间】：2023-03-29 12:51:01
【问题描述】：

我正在尝试解决以下问题（相信我，多次尝试）但没有成功...请，非常欢迎任何建议或代码！

问题：我有一堆 Excel 工作表，其中的数据以某种方式组织（这些电子表格中的数据结构不能因其他原因而更改），我需要将这些信息导出到列表中以便能够将其导入另一个应用程序。

电子表格的结构类似于以下示例：

第一列包含级别 0 的元素，在其他列中是附加级别。级别与第一行（第 1 行）中的参考相匹配。例如，单元格 A2 中的“A”位于第 0 级，而“A10”、“A20”和“A30”为第 1 级，嵌套在“A”中。 “A1010”和“A1020”是嵌套在“A10”中的第2级，依此类推。

级别数、包含信息的行数和列数可以变化很大。

    | A |  B  |   C   |   D   |   E   |   F   |   G   |
----+---+-----+-------+-------+-------+-------+-------|
  1 |   |  A  |  A10  | A1010 | A1020 |  A30  | A3010 |
  2 | A | A10 | A1010 | A1011 | A1021 | A3010 | A3011 |
  3 | B | A20 | A1020 | A1012 | A1022 | A3030 | A3012 |
  4 | C | A30 |       | A1013 | A1023 | A3070 | A3013 |
  5 | D |     |       | A1014 | A1025 | A3090 | A3019 |
  6 |   |     |       | A1019 | A1027 |       |       |
  7 |   |     |       |       | A1029 |       |       |
  8 |   |     |       |       |       |       |       |

最终列表需要以这种方式构建，以供其他应用程序读取。所有对应的嵌套级别都需要是顺序的，如下所示。

A          <--- Level 0
A10        <--- Level 1 (nested in "A")
A1010      <--- Level 2 (nested in "A10")
A1011      <--- Level 3 (nested in "A1010")
A1012      <--- Level 3 (nested in "A1010")
A1013            ...
A1014
A1019
A1020      <--- Level 2 (nested in "A10")
A1021      <--- Level 3 (nested in "A1020")
A1022            ...
A1023
A1025
A1027
A1029
A20
A30
A3010
A3011
A3012
A3013
A3019
A3030
A3070
A3090
B
C
D

感谢您的帮助。

更新：

代码将嵌入到这些 excel 文件中，但文件是只读的，不应在文件中写入任何数据。
最终，输出将是一个 TXT 文件。因此，包含最终排序数据的数组将非常受欢迎，因为我们可以使用该数组来执行其他需要的任务。
我需要知道每个实例的级别。

【问题讨论】：

IF 我理解正确，算法很简单。（从最右边的列作为“当前”列开始 (1) 在“当前”列左侧的列中的任意位置找到其第一行中的值 (2) 将“当前”列的所有其他行插入到下方找到的位置（将找到的列中的其他单元格向下推）（3）使“当前”列左侧的下一列成为新的“当前”列（4）重复，除非“当前”列是A。）但是你的问题没有任何迹象表明您的代码中有什么不工作。
你说得对，我没有显示我的代码。但这只是因为我无法得到任何合理的结果。您的方法很有趣，但我无法弄清楚如何获得每个实例的级别...
我的方法是使用两个 Do-Loop，一个在另一个内部，就像一个循环系统通过一个 2D 数组。但是，我试图使用两个数组变量来控制正在读取的行和列的索引，并将这些数组的大小连接到相应的级别。这意味着，如果找到一个新级别，则数组大小将增加一，直到获得该级别的所有数据。一旦发生这种情况，数组就会重新调整为更短的大小（一个单位）。在该层级的索引中，数组的值是已经读取的excel行和列的索引。
我不知道我是否说清楚了，但我承认这种方法远非简单......
对不起。我认为您问题中的 <--- Level 3 (nested in "A1010") 位只是 cmets。我以为您只需要按照级别隐含的顺序对数据进行排序，而没有意识到您实际上也需要显示“级别”。

标签： algorithm excel loops sorting vba

【解决方案1】：

如果我自己编写此代码（而不是试图为其他人解释编写此代码的方法），我会执行以下操作：

Type ValueAndLevel
    dataValue As String
    dataLevel As Long
End Type

Dim myData() As ValueAndLevel

Sub Export1()
    ReDim myData(1 To 1)
    'Start the process in column 1, with level being 0
    Process 1, 0
    'Get rid of the last dummy entry added to the array
    ReDim Preserve myData(1 To UBound(myData) - 1)
End Sub

Sub Process(c As Long, l As Long)
    Dim vl As ValueAndLevel
    Dim r As Long
    Dim c1 As Long
    'Start this column at row 2
    r = 2
    Do While Cells(r, c).Value <> ""
        'Store this cell's details
        vl.dataValue = Cells(r, c).Value
        vl.dataLevel = l
        myData(UBound(myData)) = vl
        'Increase size of array ready for next value
        ReDim Preserve myData(1 To UBound(myData) + 1)
        'search for sublevels starting from the column to the right
        c1 = c + 1
        Do While Cells(1, c1).Value <> ""
            If Cells(1, c1).Value = Cells(r, c).Value Then
                'If this column's row 1 matches the value we are looking for,
                'process the column (at a level one deeper than we were at)
                Process c1, l + 1
                'Don't look for any more matching values - assume only one per customer
                Exit Do
            End If
            c1 = c1 + 1
        Loop
        'Get ready to process the next row in this column
        r = r + 1
    Loop
End Sub

Export1 运行结束时，myData 数组将包含相关值及其相关级别。

【讨论】：

我不得不承认这段代码令人印象深刻。我永远不会得到这样的解决方案。结果正是我希望达到的。非常感谢！

【解决方案2】：

我想我明白了。您能否验证一下这段代码是否可以优化？

Sub Export()

Dim rFirstCell As Range
Dim vValue, vValueTemp As Variant
Dim iCol As Integer
Dim iLevel As Integer
Dim iRowIndex(), iColIndex() As Integer
Dim sSortArray() As String 'Stores the final sorted items
Dim iLevelArray() As Integer 'Stores the levels of each item

ReDim iRowIndex(0)
ReDim iColIndex(0)
ReDim sSortArray(0)
ReDim iLevelArray(0)

'Define
Set rFirstCell = Application.ActiveSheet.Cells(1)
vValue = rFirstCell.Offset(1, 0).Value

If vValue <> Empty Then 'check if there's a value to run the script
    iRowIndex(iLevel) = iRowIndex(iLevel) + 1
    vValue = rFirstCell.Offset(iRowIndex(iLevel), iColIndex(iLevel)).Value
    Do While vValue <> Empty

        'Stores the values
        iLevelArray(UBound(iLevelArray)) = iLevel
        sSortArray(UBound(sSortArray)) = vValue

        'Check if there's a new level using a temp value
        vValueTemp = rFirstCell.Offset(0, iColIndex(iLevel)).Value

        Do While vValueTemp <> Empty
            If vValueTemp = vValue Then
                'New level found
                iLevel = iLevel + 1
                ReDim Preserve iRowIndex(iLevel)
                ReDim Preserve iColIndex(iLevel)
                iColIndex(iLevel) = iCol
                Exit Do
            Else
                iCol = iCol + 1
                vValueTemp = rFirstCell.Offset(0, iCol).Value
            End If
        Loop
        iCol = 0

        iRowIndex(iLevel) = iRowIndex(iLevel) + 1

        vValue = rFirstCell.Offset(iRowIndex(iLevel), iColIndex(iLevel)).Value

        'Check if the value is not empty and
        Do While vValue = Empty
            'The value is empty so, decrease the level
            If iLevel = 0 Then
                Exit Do
            Else
                iLevel = iLevel - 1
                ReDim Preserve iRowIndex(iLevel)
                ReDim Preserve iColIndex(iLevel)
                iRowIndex(iLevel) = iRowIndex(iLevel) + 1
            End If
            vValue = rFirstCell.Offset(iRowIndex(iLevel), iColIndex(iLevel)).Value
        Loop

        If vValue <> Empty Then
            ReDim Preserve iLevelArray(UBound(iLevelArray) + 1)
            ReDim Preserve sSortArray(UBound(sSortArray) + 1)
        End If
    Loop
End If


End Sub

【讨论】：

FWIW - 您的代码在针对问题中的数据运行时，只会生成包含 "A"、"B"、"C" 和 "D" 的数组。我认为这意味着问题的数据与您在工作表中的实际数据不匹配。
我的代码正在运行，因为在我的工作表上，单元格 A1 不是空的。但是，如果单元格 A1 是空的，那么您是对的，结果将只是“A”……到“D”。

【解决方案3】：

此代码将以您希望的方式重新排列您提供的示例。

Sub Rearrange()
    ' 01 Sep 2017

    Dim Rng As Range
    Dim ArrIn As Variant
    Dim ArrOut As Variant
    Dim i As Long, j As Long
    Dim R As Long, C As Long

    C = Columns("K").Column                                 ' output column
    With Worksheets("GML")
        Set Rng = .Range(.Cells(2, "A"), .Cells(7, "G"))    ' input range
        ArrIn = Rng.Value
        ReDim ArrOut(1 To Rng.Cells.Count)
        For i = LBound(ArrIn) To UBound(ArrIn)
            For j = LBound(ArrIn, 2) To UBound(ArrIn, 2)
                R = R + 1
                ArrOut(R) = ArrIn(i, j)
            Next j
        Next i

        Set Rng = .Cells(2, C).Resize(UBound(ArrOut))
        Rng.Value = Application.Transpose(ArrOut)

        With .Sort
            With .SortFields
                .Clear
                .Add Key:=Rng, _
                     SortOn:=xlSortOnValues, _
                     Order:=xlAscending, _
                     DataOption:=xlSortNormal
            End With
            .SetRange Rng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

【讨论】：

有些事情让我认为示例数据只是示例数据，例如。 “A”可能是“Apples”，“B”可能是“Oranges”，“C”可能是“Lemons”，“A10”可能是“Red apples”，“A20”可能是“Green apples”等。尽管如此，在 OP 提供更好的示例数据（或说明他们自己的代码有什么问题）之前，这个答案与解决问题的任何方法一样好。
@YowE3K :-) 因此，我在介绍我的想法时用了谨慎的话。但是我认为可以通过在循环中使用代码来维护 Apples、Oranges 和 Lemons 的顺序，将问题转移到如何定义 Rng 并且我没有为此投入时间。
确实，这只是一个示例数据。并且范围可能因文件而异。我忘了提到，虽然代码要嵌入到这些 excel 文件中，但这些文件是只读的，并且此代码的输出将是一个文本文件。意思是，文件中不应写入任何数据。
@GML Excel 文件可以是只读的，并且仍然可以写入信息。将信息写入 Excel 中的某个范围后，可以将该范围写入文本文件，并且可以关闭 Excel 文件而不保存更改。
我不知道。但是，我避免在文件中写入任何内容。