Question

仅供参考-我是VBA的新手。我有一个每周使用我编写的几个宏创建的报告。这些宏之一使用下面的代码将列重新排列为特定顺序。

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函数的高级重组功能（参见章节 [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

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

helper函数简单地返回一个数组，该数组具有在当前标题中找到的正确的列号；它使用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

相关链接

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

基于标题名称的Excel VBA移动列

2 个答案: