Excel 基于数字列标题对列重新排序

我用这段代码根据第1行（列标题）中1到29之间的数字对Excel模型中的列重新排序

我将从客户端接收数据，其中一些列与我需要的内容相关，而其他列则与我不相关

相关列被分配一个介于1和29之间的数字，而不相关列则没有数字（第1行中的空白值）

到目前为止，该代码仍然有效；它以适当的间距将列从1重新排序到29（即，如果我有1和4，但没有2和3，那么1将在列A中，4将在列D中，列B和C将为空），并且任何没有数字的列都将被推到列AC之后

此代码仅在有标记为1和29的列时有效。如果没有29，则不相关的列将占据a和AC之间的列

我附上了一些解释它的截图

宏输入和输出的屏幕截图

如果我想让这个宏工作，我必须手动添加一个第1行中带有“29”的列。即使我没有“29”，我如何让它工作

Dim new\u column\u order作为变量，new\u index作为整数
Dim作为范围找到，计数器作为整数
新列顺序=数组（“1”、“2”、“3”、“4”、“5”、“6”、“7”、“8”、“9”、“10”、“11”、“12”、“13”、“14”，
"15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29")
计数器=1
对于新索引=LBound（新列顺序）到UBound（新列顺序）
设置Find=Rows（“1:1”）。Find（新列）顺序（新索引），LookIn:=xlValues，LookAt:=xlother，
SearchOrder:=xlByColumns，SearchDirection:=xlNext，MatchCase:=False）
如果找不到，那就什么都没有了
如果找到，则为列计数器
发现，发现
列（计数器）。插入移位：=xlToRight
如果结束
计数器=计数器+1
如果结束
下一个新索引
我和我一样长，我和我一样长
对于i=范围（“A1”）。单元格的值（1，Columns.Count）。结束（xlToLeft）。值
j=单元（1，i+1）-单元（1，i）
如果j>1，则
列（i+1）.调整大小（，j-1）.插入
i=i+j-1
如果结束
接下来我

您可以轻松地添加更多的代码，并在第一行中找到最大值及其列。

---

然后替换29，最大值，结果是需要在最大值列位置后插入的行数。您将看到图片上的情况。

您可以轻松添加更多的代码，并在第一行找到最大值及其列。

---

然后替换29，最大值，结果是需要在最大值列位置后插入的行数。您将看到图片上的情况。

阵列方法

此解决方案演示了通过一个代码行在二维数据数组（

[1]

）上应用的

应用程序.Index（）

函数（

[2]

）的重构功能。除了数组引用本身，此函数还需要两个参数：

所有所需行的“垂直”数组

按任意顺序排列的所需列的“平面”数组

最终，所有数组项都被写回（任意）范围（

[3]

）

顺便说一句，通过VBA在一个范围内循环非常耗时，所以在大多数情况下我更喜欢数组方法

---

阵列方法

此解决方案演示了通过一个代码行在二维数据数组（

[1]

）上应用的

应用程序.Index（）

函数（

[2]

）的重构功能。除了数组引用本身，此函数还需要两个参数：

所有所需行的“垂直”数组

按任意顺序排列的所需列的“平面”数组

最终，所有数组项都被写回（任意）范围（

[3]

）

顺便说一句，通过VBA在一个范围内循环非常耗时，所以在大多数情况下我更喜欢数组方法

---

你有什么版本的Excel？PowerQuery/Get&Transform可以很容易地对列进行重新排序。听起来有点蹩脚，但在向工作表中添加28列后，您可以剪切/粘贴（而不是剪切/插入），因此所有数据只能显示在“AC”中，并且更右，而不能向前放置。我必须手动添加第1行中带有“29”的列。使VBA添加不存在的额外29。您可以稍后使用VBA删除它您有什么版本的Excel？PowerQuery/Get&Transform可以很容易地对列进行重新排序。听起来有点蹩脚，但在向工作表中添加28列后，您可以剪切/粘贴（而不是剪切/插入），因此所有数据只能显示在“AC”中，并且更右，而不能向前放置。我必须手动添加第1行中带有“29”的列。使VBA添加不存在的额外29。你可以稍后用VBASorry删除它，我有点困惑。你能把你提议的代码贴出来吗？对不起，我有点困惑。您能发布您建议的代码吗？@chrisphils26希望您能反馈我最近针对您基于数组和Application.Index（）函数的高级可能性的重组问题的解决方案。如果有帮助，请随时投票：）@chrisphils26希望您能反馈我最近针对您的基于数组的重组问题的解决方案以及Application.Index（）函数的高级可能性。如果有帮助，请随意投票：）

Dim new_column_order As Variant, new_index As Integer
Dim found As Range, counter As Integer

new_column_order = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", 
"15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29")

counter = 1

For new_index = LBound(new_column_order) To UBound(new_column_order)

    Set found = Rows("1:1").Find(new_column_order(new_index), LookIn:=xlValues, LookAt:=xlWhole, 
    SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

    If Not found Is Nothing Then
        If found.Column <> counter Then
            found.EntireColumn.Cut
            Columns(counter).Insert Shift:=xlToRight
        End If

        counter = counter + 1
    End If

Next new_index

Dim i As Long, j As Long
For i = Range("A1").value To Cells(1, Columns.Count).End(xlToLeft).value
    j = Cells(1, i + 1) - Cells(1, i)
    If j > 1 Then
        Columns(i + 1).Resize(, j - 1).Insert
        i = i + j - 1
    End If
Next i

Sub RearrangeColumns()
' Purpose: a) rearrange columns based on numerical headers
'          b) sort header columns to the left,
'          c) untitled columns after 29 columns to the right
  With Sheet1                                               ' worksheet referenced e.g. via CodeName

    ' [0] identify range
      Const lastCol& = 29
      Dim LastRow&
      LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row        ' get last row
      Dim rng As Range
      Set rng = .Range(.Cells(1, 1), .Cells(LastRow, lastCol + 1))

    ' ~~~~~~~~~~~~
    ' [1] get data
    ' ~~~~~~~~~~~~
      Dim v: v = rng                                        ' assign to 1-based 2-dim datafield array

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' [2] restructure column order in array in a one liner
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      v = Application.Index(v, Evaluate("row(1:" & LastRow & ")"), getColNums(v))

    ' [3] write data back to any sheet (<~ change to your needs)
      Sheet2.Range(rng.Address) = vbNullString                                    ' clear orginal data
      Sheet2.Range("A1").Resize(UBound(v), UBound(v, 2)) = v      ' write new data

  End With

End Sub

Function getColNums(arr) As Variant()
' Purpose: return array of found column number order, e.g. Array(3,2,1,4,6,5)
Dim titles                                                ' current titles
titles = Application.Transpose(Application.Transpose(Application.Index(arr, 1, 0)))

Dim ColCount&: ColCount = UBound(arr, 2) - 1
ReDim tmp(1 To 2 * ColCount)                              ' temporary array to collect found positions

Dim c&, cc&, i&, pos
'a) left part (titled & numerically sorted columns)
For c = 1 To ColCount                                     ' loop through titles in intended order to allow sort
    pos = Application.Match(c, titles, 0)                 ' column number position in titles
    If Not IsError(pos) Then
        i = i + 1: tmp(i) = pos
    End If
Next c
'b) empty mid part
For c = i + 1 To ColCount
    tmp(c) = ColCount + 1                                  ' blank column reference 30
Next c
'c) right part (without column titles)
For c = 1 To UBound(titles)
    If Len(titles(c)) = 0 Then
        cc = cc + 1: tmp(ColCount + cc) = c
    End If
Next c

ReDim Preserve tmp(1 To ColCount + cc)                    ' remove empty elements
getColNums = tmp                                          ' return array with current column numbers (1-based)
End Function