VBA Array, rearrange columns by header name “Run-time error ‘9’: Subscript out of range”-CodePudding

The following code executes nicely, however throws the following error- “Run-time error ‘9’: Subscript out of range”. Using the code from: How to rearrange the excel columns by the columns header name , I added my 10 headers into the array in the order that I want them sorted. I have 149 header columns and 10 items in the array. I don’t know how to tell it to stop when the last value in the array is found and copied. Any help is greatly appreciated.

Sub Rearrange_Columns()
    Dim correctOrder() As Variant
    Dim lastCol As Long
    Dim headerRng As Range
    Dim cel As Range
    Dim mainWS As Worksheet
    
    Set mainWS = ActiveWorkbook.Worksheets("Sheet1")
    
    correctOrder = Array("COUNTER", "day", "mon", "year", "hr", "min", "sec", "CAT1", "DOG1", "TIK")
    
    With mainWS
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set headerRng = .Range(.Cells(1, 1), .Cells(1, lastCol))
    End With
    
    Dim newWS As Worksheet
    Set newWS = ActiveWorkbook.Sheets.Add
    newWS.Name = "Rearranged Sheet"
    
    Dim col As Long
    With newWS
        For col = 1 To lastCol
            For Each cel In headerRng
                If cel.Value = correctOrder(col - 1) Then
                    mainWS.Columns(cel.Column).Copy .Columns(col)
                    Exit For
                End If
            Next cel
        Next col       
    End With
End Sub

CodePudding user response：

You can use Match to locate the column without looping through them.

Option Explicit

Sub Rearrange_Columns()

    Dim correctOrder() As Variant
    correctOrder = Array("COUNTER", "day", "mon", "year", "hr", "min", "sec", "CAT1", "DOG1", "TIK")
    
    Dim newWS As Worksheet, i As Long, v
    Set newWS = ActiveWorkbook.Sheets.Add
    newWS.Name = "Rearranged Sheet"
    
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets("Sheet1")
        For i = 0 To UBound(correctOrder)
            v = Application.Match(correctOrder(i), .Rows(1), 0)
            If IsError(v) Then
                MsgBox "'" & correctOrder(i) & "' not found", vbExclamation
            Else
               .Columns(v).Copy newWS.Columns(i   1)
            End If
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub