VBAの列の並べ替え

Question

現在作業中のコードでは、VBAの列を並べ替える必要があります。それはヘッダに従って整理されなければならず、ヘッダは"Vd（1）"、 "Vg（1）"、 "Id（1）"、 "Ig（1）"であり、このセットは番号2 、3等（例えば、Vd（2）、Ig（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 

私は非常に新しいVBAですので、私が作成したダムコードについては私を許してください！事前に皆様ありがとうございます！

Answer 1

指定された配置で列を選択するSQLとRegExソリューションを考えてみましょう。 SQLは、WindowsのJet/ACE SQL Engineにアクセスしてデータベーステーブルのような独自のワークブックを照会できるPC用のExcelで動作します。

3から10の範囲の可変性のため、定義された関数FindHighestNumberSetを使用して、RegExを使用して列見出しから数値を抽出することで、最も高い数値セットを見つけることを検討してください。次に、RunSQLサブルーチンがSQL文字列を動的に構築する関数を呼び出すようにします。以下は

は、現在結果ます出力クエリの結果という名前の空のタブを使用してデータという名前のタブ内のデータを前提としています。 2つのADO接続文字列を使用できます。

機能（最高数を抽出する列ヘッダを横切って反復）

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 

Answer 2

次のことができこのようなものでヘルパー行で垂直方向に並べ替えます（テスト済み）：

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