重新排列VBA中的列
我正在处理的当前代码要求我重新排列VBA中的列。 它必须根据标题进行排列，并且标题是“Vd（1）”，“Vg（1）”，“Id（1）”，“Ig（1）” ，并且该集合重复用于数字2,3等（如Vd（2），Ig（4） ）。 这些数据通常是混乱起来的，我必须把它们按升序排列。
Vg，Vd，Id或Ig排在第一位并不重要。
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 我对VBA很新，所以请原谅我创build的任何哑代码！ 提前谢谢大家！
考虑SQL和RegEx解决scheme来select指定排列中的列。 SQL可以在Excel的PC上运行，它可以访问Windows的Jet / ACE SQL Engine，像查询数据库表一样查询自己的工作簿。
由于3-10集的variables性质，请考虑使用定义的函数FindHighestNumberSet通过使用RegEx从列标题中提取数字来查找最高数字集。 然后让RunSQL子程序dynamic调用函数来构buildSQLstring。
下面假设您有一个名为DATA的选项卡中有一个名为RESULTS的空选项卡，它将输出查询结果。 两个ADO连接string可用。
函数 （遍历列标题提取最高的数字）
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
macros （通过上述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.[Vd(1)], t.[Id(1)], t.[Ig(1)]," _ & " t.[Vd(2)], t.[Id(2)], t.[Ig(2)]," _ & " t.[Vd(3)], t.[Id(3)], t.[Ig(3)]" ' VARIABLE 4+ SETS For i = 4 To FindHighestNumberSet strSQL = strSQL & ", t.[Vd(" & i & ")], t.[Id(" & i & ")], t.[Ig(" & 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
你可以用一个像这样的东西（testing）垂直排列帮助器行：
Sub test() ': Cells.Delete: [b2:d8] = Split("Vd(10) Vd(2) Vd(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