VBA按表头重排列时出现Run-time error '9'下标越界错误如何解决

错误原因 #

• 你当前的循环逻辑是遍历原表的所有149列，每次都访问correctOrder(col-1)，但你的correctOrder数组只有10个元素，下标范围是0~9，当col值大于等于11时，col-1就超过了数组的最大下标，直接触发下标越界错误。
• 你只需要保留10个指定列，不需要遍历原表全部149列，循环次数只要和数组长度一致即可实现处理完指定列就终止的需求。

修复后代码 #

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 i As Long
    With newWS
        ' 循环次数和correctOrder数组长度一致，处理完10个表头就自动终止
        For i = LBound(correctOrder) To UBound(correctOrder)
            For Each cel In headerRng
                If cel.Value = correctOrder(i) Then
                    ' 第i+1列写入对应数据，因为数组从0开始，新表列从1开始
                    mainWS.Columns(cel.Column).Copy .Columns(i + 1)
                    Exit For
                End If
            Next cel
        Next i
    End With
End Sub

效率优化方案 #

可以用Find方法替代嵌套循环，匹配速度更快，同时可以兼容表头不存在的异常场景：

For i = LBound(correctOrder) To UBound(correctOrder)
    Dim match As Range
    Set match = headerRng.Find(correctOrder(i), LookIn:=xlValues, lookat:=xlWhole)
    If Not match Is Nothing Then
        mainWS.Columns(match.Column).Copy .Columns(i + 1)
    Else
        ' 找不到对应表头时可以在新表对应位置写提示，也可以直接删除该行跳过
        .Cells(1, i + 1) = "未找到列：" & correctOrder(i)
    End If
Next i

内容的提问来源于stack exchange，提问作者jto843