求助：VBA代码删除所有工作表前10行正常，但仅首表列重排的修复

Ah, I see the issue here—your column reordering logic is probably sitting outside the For Each ws loop, so it only runs once on the first worksheet you process. Let's fix that by moving the column rearrangement code inside the loop so it applies to every sheet in the workbook.

Here's the corrected VBA code, with comments explaining each step:

Sub gram_em()
    Dim ws As Worksheet
    Dim strFile As String
    Dim desiredColumns As Variant
    Dim colIndex As Integer
    Dim newColOrder As Range
    Dim foundCol As Range
    
    ' --------------------------
    ' Step 1: Define your desired column order
    ' Replace these with your actual header names (exact matches!)
    ' Include all columns you want to keep, in the order you need
    desiredColumns = Array("CustomerID", "Name", "Email", "OrderDate", "TotalAmount") ' Add your headers here
    ' --------------------------
    
    ' Get the target workbook
    strFile = Application.GetOpenFilename
    If strFile = "False" Then Exit Sub ' Exit if user cancels file picker
    
    Application.Workbooks.Open (strFile)
    
    ' Turn off screen updating to speed up the process
    Application.ScreenUpdating = False
    
    ' Loop through every worksheet in the opened workbook
    For Each ws In ActiveWorkbook.Worksheets
        ' 1. Delete the first 10 rows to move headers to row 1
        ws.Rows("1:10").Delete Shift:=xlUp
        
        ' 2. Reorder columns to match your desired sequence
        Set newColOrder = Nothing ' Reset for each sheet
        
        ' Loop through each desired column header
        For colIndex = LBound(desiredColumns) To UBound(desiredColumns)
            ' Find the column with the matching header in the current sheet
            On Error Resume Next
            Set foundCol = ws.Rows(1).Find( _
                What:=desiredColumns(colIndex), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                MatchCase:=False ' Set to True if headers are case-sensitive
            )
            On Error GoTo 0
            
            ' If we found the column, add it to our new column range
            If Not foundCol Is Nothing Then
                If newColOrder Is Nothing Then
                    Set newColOrder = foundCol.EntireColumn
                Else
                    Set newColOrder = Union(newColOrder, foundCol.EntireColumn)
                End If
            End If
        Next colIndex
        
        ' Move the desired columns to the leftmost position
        If Not newColOrder Is Nothing Then
            newColOrder.Cut
            ws.Columns(1).Insert Shift:=xlToRight
            Application.CutCopyMode = False ' Clear cut/copy mode
        End If
    Next ws
    
    ' Turn screen updating back on
    Application.ScreenUpdating = True
    
    ' Let the user know we're done
    MsgBox "All sheets processed successfully!", vbInformation
End Sub

Key Fixes & Notes: #

• Moved column reorder inside the loop: Now every worksheet gets its columns rearranged, not just the first one.
• Uses header names instead of indices: This is more reliable because it works even if column positions vary between sheets (perfect for your mix of 40 and 44 column sheets).
• Customizable column order: Just update the desiredColumns array with your actual header text (make sure they match exactly—case-insensitive by default, but you can change that if needed).
• Error handling: Added checks for canceled file picker and missing columns (so the script won't break if a column is missing from a sheet).

Make sure to test this on a copy of your workbook first, just to be safe!

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