重新排序列 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

上述主程序調用的助手 function

助手 function 只返回一個數組，其中包含在當前標題中找到的正確列號； 它使用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. 在幫助 function getColNums中添加（可選）第二個參數DeleteRest ，
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]節）

修改幫助 function 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 或 API 調用中列出了Application.Index function 的一些特性