Question

我有这段代码根据行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之间的列。我知道这可能会造成混淆，因此我附上了一些截图进行解释。

[Screenshots of Macro Input and Output] 1

现在，如果我希望此宏正常工作，则必须在第1行中手动添加带有“ 29”的列。有人可以帮我弄清楚如何使它起作用，即使我没有“ 29“？谢谢！

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

Answer 1

您可以轻松添加更多代码，并在第一行中找到最大值及其列。然后用29代替那个最大值，结果是您需要在最大值列位置之后插入的行数。您会在照片上看到类似的情况。

Answer 2

数组方法

此解决方案演示了通过一条代码行应用于二维数据数组（Application.Index()）上的[2]函数（[1]）的重组功能。除了数组引用本身之外，此函数还需要另外两个参数：

所有需要的行的“垂直”数组，
以任意顺序排列的所需列的“平面”数组。

最终所有数组项都写回到（任何）范围（[3]）。

顺便说一句，通过VBA遍历范围非常耗时，因此在大多数情况下，我更喜欢使用数组方法。

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

上述主要过程调用的帮助功能getColNums()

帮助功能getColNums()仅返回在当前标题中找到的所有有效列标题编号的数组。它使用Application.Match查找事件：

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

根据数字列标题对列重新排序

2 个答案: