Algorithm VBA Excel棘手的“嵌套”列排序

我一直在努力解决以下问题相信我，很多尝试都没有成功。。。请，任何建议或代码都非常欢迎

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

电子表格的结构如下所示：

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

级别、包含信息的行和列的数量可能会发生很大变化

    | 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文件。因此，包含最终排序数据的数组将非常受欢迎，因为我们可以使用该数组执行其他需要的任务。 我需要知道每个实例的级别。

---

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

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

我想我明白了。 您能否验证此代码是否可以优化

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

---

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

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数组将包含相关值及其关联级别。

如果我正确理解了要求，那么算法非常简单。从最右边的列开始作为当前列1在当前列左侧列的任何位置查找其第一行中的值2在查找位置下方插入当前列的所有其他行向下推查找列中的其他单元格3使当前列左侧的下一列成为新的当前列4重复，除非当前列是A。但您的问题没有显示代码中有什么不起作用。您是对的，我没有显示我的代码。但那只是因为我不能用它得到任何合理的结果。你的方法很有趣，但我不知道如何获得每个实例的级别…我的方法是使用两个Do循环，一个在另一个内部，就像一个循环系统通过2D数组。但是，我尝试使用两个数组变量来控制正在读取的行和列的索引，并将这些数组的大小连接到相应的级别。也就是说，如果找到新的级别，数组大小将增加1，直到获得该级别的所有数据。一旦发生这种情况，阵列将被重新分配到一个较小的单元。在该级别的索引中，数组的值是已经读取的excel行和列的索引。我不知道我是否已经讲清楚了，但我承认这种方法远不简单……对不起。我认为这个东西让我觉得样本数据就是样本数据，例如。A可能是苹果，B可能是桔子，C可能是柠檬，A10可能是红苹果，A20可能是绿苹果，等等。不过，直到OP提供了更好的样本数据，或者说他们自己的代码出了什么问题，这个答案在解决这个问题上还是很好的。@YowE3K:-因此，我谨慎地介绍了我的想法。但我认为苹果、橙子和柠檬的顺序可以通过在循环中使用代码来维护，将问题转移到如何定义Rng上，我没有为此投入时间。事实上，这只是一个样本数据。而且范围因文件而异。我忘了提到，虽然代码要嵌入到这些excel文件中，但这些文件是只读的，并且代码的输出将是文本文件。也就是说，不应该在文件中写入任何数据。@GML Excel文件可以是只读的，并且仍然可以写入信息。将信息写入Excel中的某个区域后，该区域可以写入文本文件，并且Excel文件可以在不保存更改的情况下关闭。我不知道。但是，我避免在files.FWIW中写入任何内容-当您的代码针对问题中的数据运行时，只会生成包含A、B、C和D的数组。我假设这意味着问题的数据与工作表中的实际数据不匹配。我的代码起作用，因为在我的工作表中，单元格A1不是空的。但是，如果单元格A1是空的，你是对的，结果将只是一个。。。我得承认这段代码给人留下了深刻的印象。我永远也找不到这样的解决办法。结果正是我所想的 ping以达到。非常感谢你！