通过Excel宏按钮按列名从文本文件导入指定列到工作表的实现求助

你的思路完全可实现，以下是优化后的完整代码，仅需修改预设导入列名即可使用：

修改说明 #

• 新增了自动读取文本文件表头、生成TextFileColumnDataTypes数组的逻辑，无需手动维护上千个元素的数组
• 保留了你原有导入配置（从第208行开始导入、制表符分隔等参数），无需调整原有业务逻辑
• 仅需修改代码中targetHeaders数组内的列名，即可自定义要导入的列

完整代码 #

Option Explicit
Option Base 1

Sub importText()
    Dim FName
    Dim rDest As Range
    Dim Answer As VbMsgBoxResult
    Dim fDialog As FileDialog, Result As Integer
    ' 这里改成你需要导入的列名，和文本文件表头完全一致即可
    Dim targetHeaders As Variant
    targetHeaders = Array("test run one", "test run two") ' 按需添加更多列
    
    ' 新增变量：用于读取表头、生成类型数组
    Dim txtFileNum As Integer
    Dim headerLine As String
    Dim allHeaders As Variant
    Dim colTypeArr As Variant
    Dim i As Long, j As Long
    Dim matchFlag As Boolean
    
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
   
            
'Optional: FileDialog properties
    fDialog.AllowMultiSelect = False
    fDialog.Title = "Select a file"
    fDialog.InitialFileName = "F:\"
    
'Optional: Add filters
    fDialog.Filters.Clear
    fDialog.Filters.Add "Text/CSV files (*.txt; *.csv)", "*.txt; *.csv", 1
    
    Answer = MsgBox("Are You Sure You Want To Import A Text File?", vbYesNo, "Import A Text File")
    If Answer = vbYes Then
        Application.ScreenUpdating = False
    Else
        Exit Sub
    End If
    
    FName = Application.GetOpenFilename(filefilter:="Text/CSV files (*.txt; *.csv),*.txt;*.csv", MultiSelect:=False)
    If FName = False Then Exit Sub

    ' ========== 新增逻辑：自动生成列类型数组 ==========
    ' 读取文本文件的表头行（注意你是从第208行开始导入，所以表头是第208行）
    txtFileNum = FreeFile()
    Open FName For Input As #txtFileNum
    For i = 1 To 207 ' 跳过前207行，读到第208行表头
        Line Input #txtFileNum, headerLine
    Next i
    Line Input #txtFileNum, headerLine
    Close #txtFileNum
    
    ' 按制表符拆分表头
    allHeaders = Split(headerLine, vbTab)
    ' 初始化全9的数组，长度和总列数一致
    ReDim colTypeArr(1 To UBound(allHeaders) + 1) ' Option Base 1所以要+1
    For i = 1 To UBound(colTypeArr)
        colTypeArr(i) = 9 ' 9代表跳过该列
    Next i
    
    ' 匹配需要导入的列，把对应位置改成1（1代表常规格式导入）
    For i = 1 To UBound(targetHeaders)
        matchFlag = False
        For j = 0 To UBound(allHeaders)
            If allHeaders(j) = targetHeaders(i) Then
                colTypeArr(j + 1) = 1
                matchFlag = True
                Exit For
            End If
        Next j
        If Not matchFlag Then
            MsgBox "未找到列：" & targetHeaders(i), vbExclamation
        End If
    Next i
    ' ========== 新增逻辑结束 ==========

    Set rDest = ActiveSheet.Cells(1, 1)
   
    With rDest.Worksheet.QueryTables.Add(Connection:= _
        "TEXT;" & FName, Destination:=rDest)
        .Name = "new 1_1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 208
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        ' 替换成自动生成的数组
        .TextFileColumnDataTypes = colTypeArr
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    Application.ScreenUpdating = True
    MsgBox "导入完成", vbInformation
End Sub

使用说明 #

• 找到代码中targetHeaders = Array("test run one", "test run two")这一行，把括号里的内容换成你实际需要导入的列名，列名要和文本文件里的表头完全一致
• 如果需要导入6列，直接在Array里加就行，比如Array("列1","列2","列3","列4","列5","列6")
• 若运行时提示找不到某列，检查列名拼写、是否有多余空格即可

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