Excel VBA中的列重排

我正在处理的当前代码要求我重新排列VBA中的列。它必须根据标题进行排列，标题是“V-d（1）”，“V-g（1）”，“I-d（1）”，“I-g（1）”，“I-g（1）”，此集合重复用于数字2、3等（例如V-d（2）、I-g（4））。这些数据通常杂乱无章，我不得不按升序排列。

V-g、V-d、I-d或I-g排在第一位并不重要

Dim num, numadj As Integer
Dim colu, coladj
Range("A1").Select
Do While Range("A1").Offset(0, i - 1).Value <> ""
    colu = ActiveCell.Value
    coladj = ActiveCell.Offset(0, 1).Value
    num = Left(Right(colu.Text, 2), 1)
    numadj = Left(Right(coladj.Text, 2), 1)
    If num > numadj Then
        colu.EntireColumn.Cut Destination:=Columns("Z:Z")
        coladj.EntireColumn.Cut Destination:=colu
        Columns("Z:Z").Select.Cut Destination:=coladj
        i = i + 1
    Else
    i = i + 1
    End If
Loop

Dim num，numadj为整数
暗淡的颜色
范围（“A1”）。选择
Do While范围（“A1”）。偏移量（0，i-1）。值“”
colu=ActiveCell.Value
coladj=ActiveCell.Offset（0，1）.Value
num=左（右（colu.Text，2），1）
numadj=左（右（coladj.Text，2），1）
如果num>numadj，则
colu.entireclumn.Cut目的地：=列（“Z:Z”）
coladj.entireclumn.Cut目的地：=colu
列（“Z:Z”）。Select.Cut Destination:=coladj
i=i+1
其他的
i=i+1
如果结束
环

---

我是VBA新手，所以请原谅我创建的任何愚蠢代码！！！提前谢谢大家

考虑使用SQL和正则表达式解决方案来选择指定排列中的列。SQL在Excel for PC中工作，它可以访问Windows的Jet/ACE SQL引擎，像查询数据库表一样查询自己的工作簿

由于3-10个集合的可变性质，考虑通过使用定义函数使用正则表达式提取列标题中的数字来找到最高的集合。然后让

RunSQL

子例程调用函数来动态构建SQL字符串

下面假设您当前在名为data的选项卡中有数据，而名为RESULTS的空选项卡将输出查询结果。有两个ADO连接字符串可用

函数（遍历列标题以提取最大数量）

宏（主模块循环通过上述功能的结果）

---

您可以使用以下内容（已测试）按辅助行进行垂直排序：

---

数字能延伸多远？几百？数千只？冻糕最多10只！你使用Excel for Windows吗？@parfait是的，我使用！您可以按列标题从左到右排序谢谢您的工作！如果它不总是有10套呢？系统生成3-10套，并非总是固定的。代码仍然有效吗？如前所述，调整查询的列。具体来说，请删除

SELECT

子句中的项目。你提前知道设定的号码吗？@parfair不，我不会提前知道的！集合编号由另一个系统生成，然后此代码将运行SEE update，其中SQL是通过在列标题中查找最高编号（使用RegEx提取）动态生成的。祝贺您刚刚学习了两种特殊用途的语言：SQL和RegEx！可能看起来有些过分，但您避免剪切和粘贴列。

Function FindHighestNumberSet() As Integer
    Dim lastcol As Integer, i As Integer
    Dim num As Integer: num = 0
    Dim regEx As Object

    ' CONFIGURE REGEX OBJECT
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
       .Global = True
       .MultiLine = True
       .IgnoreCase = False
       .Pattern = "[^0-9]"
    End With

    With Worksheets("DATA")
       lastcol = .Cells(7, .Columns.Count).End(xlToLeft).Column

       For i = 1 To lastcol
         ' EXTRACT NUMBERS FROM COLUMN HEADERS
         num = Application.WorksheetFunction.Max(num, CInt(regEx.Replace(.Cells(1, i), "")))
       Next i

    End With

    FindHighestNumberSet = num
End Function

Sub RunSQL()
On Error GoTo ErrHandle
    Dim conn As Object, rst As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer

    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    ' DRIVER AND PROVIDER CONNECTION STRINGS
'    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
'                      & "DBQ=" & Activeworkbook.FullName & ";"
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                       & "Data Source='" & ActiveWorkbook.FullName & "';" _
                       & "Extended Properties=""Excel 8.0;HDR=YES;"";"

    ' FIRST THREE SETS
    strSQL = " SELECT t.[V-d(1)], t.[I-d(1)], t.[I-g(1)]," _
                  & " t.[V-d(2)], t.[I-d(2)], t.[I-g(2)]," _
                  & " t.[V-d(3)], t.[I-d(3)], t.[I-g(3)]"

    ' VARIABLE 4+ SETS
    For i = 4 To FindHighestNumberSet
        strSQL = strSQL & ", t.[V-d(" & i & ")], t.[I-d(" & i & ")], t.[I-g(" & i & ")]"
    Next i

    ' FROM CLAUSE
    strSQL = strSQL & " FROM [DATA$] t"

    ' OPEN DB CONNECTION
    conn.Open strConnection
    rst.Open strSQL, conn

    ' COLUMN HEADERS
    For i = 1 To rst.Fields.Count
        Worksheets("RESULTS").Cells(1, i) = rst.Fields(i - 1).Name
    Next i

    ' DATA ROWS
    Worksheets("RESULTS").Range("A2").CopyFromRecordset rst

    rst.Close: conn.Close
    Set rst = Nothing: Set conn = Nothing

    MsgBox "Successfully ran SQL query!", vbInformation
    Exit Sub

ErrHandle:
    Set rst = Nothing: Set conn = Nothing
    MsgBox Err.Number & " = " & Err.Description, vbCritical
    Exit Sub
End Sub

Sub test() ': Cells.Delete: [b2:d8] = Split("V-d(10) V-d(2) V-d(1)") ' used for testing
    Dim r As Range: Set r = ThisWorkbook.Worksheets("Sheet1").UsedRange  ' specify the range to be sorted here

    r.Rows(2).Insert xlShiftDown ' insert helper row to sort by. (used 2nd row instead 1st so that it is auto included in the range)
    r.Rows(2).FormulaR1C1 = "=-RIGHT(R[-1]C,LEN(R[-1]C)-3)" ' to get the numbers from the column header cells above, so adjust if needed

    r.Sort r.Rows(2) ' sort vertically by the helper row
    r.Rows(2).Delete xlShiftUp ' delete the temp row
End Sub