重新排序列 vba

Question

对不起，我找不到这个代码

代码根据工作表中所有列的列表对列重新排序

它适用于大量列，但它要求您列出工作表中的所有列，否则会删除未列出的列

有复制粘贴的版本，但速度很慢，不适合大量列

我只想列出我想要重新排序到工作表开头的列，所有其他列都按照它们所在的顺序排列 在重新排序的列之后

没有运气这样做

谢谢

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

Answer 1

由于标题列表而重新排列列

“我只想将我想要重新排序的列列出到工作表的开头，所有其他列都按照重新排序后列出的列的顺序排列”

够了

1. 添加一个（可选的）第二个参数 DeleteRest到帮助函数getColNums，
2. 在a) 中插入负过滤 例程以获取剩余标题（数组rest）和
3. 插入条件代码块b) 执行默认传递的参数“顺序”不删除未列出的标题

    If Not DeleteRest Then
        For i = 0 To UBound(rest)
            pos = Application.Match(rest(i), titles, 0)             ' check positions
            If Not IsError(pos) Then
                tmp(ii) = pos: ii = ii + 1
            End If
        Next i
    End If

（您可以保持调用过程 ColOrder 不变 - 请参阅 [2] 部分）

修改帮助功能getColNums()

仅当第二个参数DeleteRest（默认为False）将作为True 专门传递时，现在将删除每个未列出的列。否则不再需要列出整个标题集以防止删除。

Function getColNums(arr, Optional ByVal DeleteRest As Boolean = False) As Variant()
' Site: https://stackoverflow.com/questions/61918751/reorder-columns-vba
' Purp: return array of found column number order, e.g. Array(3,2,1,4,6,5)
' Auth: https://stackoverflow.com/users/6460297/t-m
' Date: 2020-05-25
' Note: if argument DeleteRest (default: False) is passed as True, each unlisted titles will be removed
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 rest: rest = titles
Dim i&, ii&, pos                                                ' array counters, element position
ReDim tmp(0 To UBound(colOrdr) + UBound(titles) + 2)            ' temporary array to collect found positions
' a) find position in
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
        rest = Filter(rest, colOrdr(i), False, vbTextCompare)
    End If
Next i
' b) Default: ~~~> don't remove unlisted titles  <~~~           ' << inserted code block as of 2020-05-15 >>
If Not DeleteRest Then
    For i = 0 To UBound(rest)
        pos = Application.Match(rest(i), titles, 0)             ' check positions
        If Not IsError(pos) Then
            tmp(ii) = pos: ii = ii + 1
        End If
    Next i
End If

ReDim Preserve tmp(0 To ii - 1)                                 ' remove empty elements
getColNums = tmp                                                ' return array with current column numbers (1-based)
Debug.Print Join(tmp, "|") & " ... " & Join(rest, "|")
End Function

相关链接

我在Insert first column in datafield array without loops or API calls 列出了Application.Index 函数的一些特性