如何修改VBA代码使其在X列而非A列查找"x"值

原代码通过A列的"x"值触发数据导出操作，要改为X列触发，需调整两处关键代码：

关键修改点 #

• 扩展数据数组的加载范围：原代码仅加载A-F列数据到数组arList，需扩展至X列，确保触发列被包含进数组
• 修改触发判断的列索引：将判断"x"的列从第1列（A列）改为第24列（X列），同步调整错误检查的列

修改后的完整代码 #

Option Explicit

Sub Acto_Export()
    
    Dim wb As Workbook, ws As Worksheet
    Dim SystemlistFilename As String, SystemlistSheetname
    Dim ProjectNumber As String
    Dim n As Long, r As Long, lastrow As Long
    Dim t0 As Single: t0 = Timer
    
    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet
    
    SystemlistFilename = wb.Name
    SystemlistSheetname = ws.Name
    
    'Get the project number from the active sheet
    If WorksheetFunction.IsText(ws.Range("C4")) Or Len(ws.Range("C4")) <> 8 Then
         MsgBox ("Wrong value given. No file created. please use a valid project number in C4")
         Exit Sub
    End If
    ProjectNumber = ws.Range("C4")
    
    ' output column names
    Dim dictCol As Object
    Set dictCol = CreateObject("Scripting.Dictionary")
    With dictCol
        .Add "ProjectNummer", 1
        .Add "Activiteit", 2
        .Add "ActiviteitNaam", 3
        .Add "ActiviteitSoort", 4
        .Add "Bouwdeel", 5
        .Add "BouwdeelOmschrijving", 6
        .Add "BouwdeelZoeknaam", 7
        .Add "ActiviteitSoortNaam", 8
        .Add "ZoeknaamActiviteitSoort", 9
        .Add "Categorie", 10
        .Add "CategorieNaam", 11
        .Add "Projectdeel", 12
    End With
    
    ' initial rows
    Const indIMP = 9
    Const indEXP = 2
    
    Dim arList, arOut
    With ws
        ' array of list data - 扩展范围到X列（原仅A-F）
        lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
        arList = .Range("A1:X" & lastrow) ' 修改此处：F→X
        ' array to hold output
        ReDim arOut(1 To lastrow, 1 To dictCol.Count)
    End With
      
    ' output header
    Dim arHeader
    arHeader = Array("Activiteit", "ActiviteitNaam", "ProjectNummer", _
        "ActiviteitSoort", "Bouwdeel", "BouwdeelOmschrijving", _
        "BouwdeelZoeknaam", "ActiviteitSoortNaam", "ZoeknaamActiviteitSoort", _
        "Categorie", "CategorieNaam", "Projectdeel")
        
    'Loop through data in the source sheet
    For r = indIMP To lastrow
            
        ' 修改判断列：从第1列（A）改为第24列（X）
        If LCase(arList(r, 24)) = "x" Then
            n = n + 1
            arOut(n, dictCol("Activiteit")) = "00" & arList(r, 2)
            arOut(n, dictCol("ActiviteitNaam")) = arList(r, 6)
            arOut(n, dictCol("ProjectNummer")) = "00" & ProjectNumber
            arOut(n, dictCol("ActiviteitSoort")) = "00" & arList(r, 2)
            arOut(n, dictCol("Bouwdeel")) = 0
            arOut(n, dictCol("BouwdeelOmschrijving")) = "algemeen"
            arOut(n, dictCol("BouwdeelZoeknaam")) = "alg"
            arOut(n, dictCol("ActiviteitSoortNaam")) = arList(r, 6)
            arOut(n, dictCol("ZoeknaamActiviteitSoort")) = Mid(arList(r, 6), 1, 2)
            arOut(n, dictCol("Categorie")) = 0
            arOut(n, dictCol("CategorieNaam")) = "algemeen"
            arOut(n, dictCol("Projectdeel")) = 0
        ' 同步错误检查的列到第24列
        ElseIf Len(arList(r, 24)) > 0 Then
            MsgBox "Wrong value given. No file was created. please use X : ", _
                   vbExclamation, "Error in row " & r
              
            Exit Sub
        End If
        
    Next

    ' create output file
    Dim wbACTO As Workbook, wsACTO As Worksheet
    Dim sFolder As String, ExportFileName As String
    If n > 0 Then
        ' select output folder
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = -1 Then        ' if OK is pressed
                sFolder = .SelectedItems(1)
            End If
        End With
        If sFolder = "" Then        ' if an error occured
            MsgBox ("No folder was selected")
            Exit Sub
        End If
    
        ' create new workbook
        Set wbACTO = Workbooks.Add(1)
        Set wsACTO = wbACTO.Sheets(1)
        
        ' add header
        With wsACTO ' 12 colunms
            ' Rename the export sheet
            .Name = "PLN961"
            .Range("A1:L1") = arHeader
                           
            ' Set number formats for specific columns
            .Columns("B:K").NumberFormat = "000000"
            .Columns("E:E").NumberFormat = "0"
            .Columns("I:J").NumberFormat = "0"
            .Columns("L:L").NumberFormat = "0"
            
            ' write output
            .Cells(indEXP, 1).Resize(n, UBound(arOut, 2)) = arOut
        End With
        
        ' Save the export file
        ExportFileName = sFolder & "\" & Format(Now, "yyyy-MM-dd_HHmmss_") & ProjectNumber & "_importfileActo.xlsx"
        wbACTO.SaveAs ExportFileName
        MsgBox n & " rows written to " & ExportFileName, vbInformation, Format(Timer - t0, "0.0 secs ")
    Else
        MsgBox "No output to create", vbExclamation
    End If

End Sub

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