根据标题名称移动列

Question

我有一个将列重新排列为特定顺序的宏。

Sub ArrangeColumns()

' ArrangeColumns Macro

    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:K").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("H:H").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:K").Select
    Selection.Cut
    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight
    Range("P11").Select
End Sub

这不再有效，因为无法再保证原始数据的列按特定顺序排列。

有没有办法重写上面的代码（是的，它是由“记录宏”创建的）以"Columns("C:C")", Columns("A:A")"用它们的列标题名称替换行等？

更好的是有没有更好的方法来解决这个问题？

Answer 1

如果您知道所有标题名称，则可以定义标题名称数组并使用该数组的索引来移动列。

Sub columnOrder()
Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer

colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here

cnt = 1


For indx = LBound(colOrdr) To UBound(colOrdr)
    Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not search Is Nothing Then
        If search.Column <> cnt Then
            search.EntireColumn.Cut
            Columns(cnt).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
    cnt = cnt + 1
    End If
Next indx
End Sub

数组中未命名的任何列都将出现在已命名列的右侧。

Answer 2

Application.Index在单衬里使用的替代方案

为了艺术的目的，只是为了展示使用该Application.Index功能的高级重组可能性的工作替代方案（参见第 1 节[2]）：

Sub colOrder()
' Purpose: restructure range columns
  With Sheet1                                               ' worksheet referenced e.g. via CodeName
  
    ' [0] identify range
      Dim rng As Range, lastRow&, lastCol&
      lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row        ' get last row and last column
      lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
      Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
      
    ' ~~~~~~~~~~~~
    ' [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 sheet
      rng = vbNullString                                    ' clear orginal data
      .Range("A1").Resize(UBound(v), UBound(v, 2)) = v      ' write new data
  
  End With
  
End Sub

上述主程序调用的辅助函数

辅助函数只是返回一个数组，其中包含当前标题中找到的正确列号；它用于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 colOrdr(), titles                                           ' wanted order, current titles
colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here
titles = Application.Transpose(Application.Transpose(Application.Index(arr, 1, 0)))

Dim i&, ii&, pos                                                ' array counters, element position
ReDim tmp(0 To UBound(colOrdr))                                 ' temporary array to collect found positions
For i = 0 To UBound(colOrdr)                                    ' loop through titles in wanted order
    pos = Application.Match(colOrdr(i), titles, 0)              ' check positions
    If Not IsError(pos) Then tmp(ii) = pos: ii = ii + 1         ' remember found positions, increment counter
Next i
ReDim Preserve tmp(0 To ii - 1)                                 ' remove empty elements
getColNums = tmp                                                ' return array with current column numbers (1-based)
End Function

相关链接

我在没有循环或 API 调用的情况下插入数据字段数组中的第一列Application.Index中列出了该函数的一些特性

//根据截至 2021 年 9 月 25 日的评论进行编辑

修改后的帮助函数现在包括通过第二个参数的getColNums()选项DeleteOtherCols:={False|True}

• 保留未列出的列~~>getColNums(v, DeleteOtherCols:=False)或简单地getColNums(v, False); 如果不设置第三个参数，True这些其他列将显示在列出的列的右侧（请参阅第三个参数的注释）
• 仅 重新排列列出的列（即默认情况下删除其他列）~~>getColNums(v)或getColNums(v, True)

以及通过第三个参数的选项 StartWithOtherCols:={False|True}

• 从未列出的列开始 ~~>或简单getColNums(v, False, StartWithOtherCols:=True)地getColNums(v, False, True)
• 继续处理getColNums(v,False)名为 ~~>或getColNums(v,False,False)getColNums (v,False,StartWithOtherCols:=False)``的右侧未列出的列or ：

Function getColNums(arr, _
    Optional DeleteOtherCols As Boolean = True, _
    Optional StartWithOtherCols As Boolean = False) As Variant()
' Purpose: return array of found column number order, e.g. Array(3,2,1,4,6,5)
    Dim colOrdr(), titles                        ' wanted order, current titles
    colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here
    titles = Application.Transpose(Application.Transpose(Application.Index(arr, 1, 0)))

    Dim i&, ii&, pos                             ' array counters, element position
    ReDim tmp(0 To UBound(titles) - 1)
    If StartWithOtherCols Then
        DeleteOtherCols = False                  ' correct possible input error
        ii = UBound(titles) - UBound(colOrdr) - 1 ' << EDITED: get start counter
    End If
    For i = 0 To UBound(colOrdr)                 ' loop through titles in wanted order
        pos = Application.Match(colOrdr(i), titles, 0) ' check positions
        If Not IsError(pos) Then tmp(ii) = pos: ii = ii + 1 ' remember found positions, increment counter
    Next i
    'options
    If DeleteOtherCols Then                      ' delete non-listed columns
        ReDim Preserve tmp(0 To UBound(colOrdr)) ' remove empty elements
    Else                                         ' preserve non-listed columns
        Dim tmp2
        tmp2 = Application.Match(titles, colOrdr, 0)
        If StartWithOtherCols Then ii = 0        ' start with other columns
        For i = LBound(tmp2) To UBound(tmp2)     ' loop through titles
            If IsError(tmp2(i)) Then tmp(ii) = i: ii = ii + 1
        Next i
    End If
    getColNums = tmp                             ' return array with current column numbers (1-based)

End Function