VBA需求：批量提取文件夹xls文件指定列至主表并设文件名表头

实现思路 #

1. 弹出文件夹选择框，指定待处理xls文件的存放目录
2. 遍历目录下所有xls格式文件，逐个以只读模式打开
3. 因每个文件仅含单个工作表，直接取第一个工作表（无需关注名称）
4. 提取指定目标列的数据，跳过源文件表头行
5. 将当前处理的文件名作为表头，把提取到的数据粘贴到主表的空白列
6. 关闭源文件（不保存，避免修改原文件），继续处理下一个文件

完整VBA代码 #

Sub BatchExtractColumns()
    Dim mainWS As Worksheet
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim targetCol As Integer
    Dim lastRow As Long
    Dim pasteCol As Integer
    
    ' 主表设为当前运行宏的工作表
    Set mainWS = ThisWorkbook.ActiveSheet
    ' 指定要提取的列（示例为B列，对应数字2，可自行修改）
    targetCol = 2
    ' 初始化粘贴起始列（示例从B列开始，A列可留作序号或其他用途）
    pasteCol = 2
    
    ' 选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择存放xls文件的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择文件夹，程序退出"
            Exit Sub
        End If
    End With
    
    ' 遍历文件夹下的xls文件
    fileName = Dir(folderPath & "*.xls")
    Do While fileName <> ""
        ' 打开源文件（只读模式防止锁定原文件）
        Set sourceWB = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
        ' 获取源文件的唯一工作表
        Set sourceWS = sourceWB.Sheets(1)
        
        ' 定位源文件目标列的最后一行数据
        lastRow = sourceWS.Cells(Rows.Count, targetCol).End(xlUp).Row
        
        ' 写入表头（去掉.xls后缀）
        mainWS.Cells(1, pasteCol).Value = Left(fileName, Len(fileName) - 4)
        
        ' 复制目标列数据（从第2行开始，跳过源文件表头）
        sourceWS.Range(sourceWS.Cells(2, targetCol), sourceWS.Cells(lastRow, targetCol)).Copy
        ' 粘贴值到主表对应列
        mainWS.Cells(2, pasteCol).PasteSpecial xlPasteValues
        
        ' 关闭源文件，不保存任何修改
        sourceWB.Close SaveChanges:=False
        
        ' 切换到下一列准备粘贴
        pasteCol = pasteCol + 1
        ' 获取下一个文件名
        fileName = Dir
    Loop
    
    ' 清除剪贴板，取消选中状态
    Application.CutCopyMode = False
    MsgBox "批量提取完成！"
End Sub

关键调整说明 #

• 修改目标列：将代码中targetCol = 2改为你需要提取的列号（比如C列对应数字3）
• 保留文件后缀：如果需要表头显示完整文件名（含.xls），把Left(fileName, Len(fileName) - 4)替换为fileName即可
• 调整起始列：若主表A列已有内容，将pasteCol = 2改为你想开始的列号（比如从C列开始就设为3）
• 错误兼容：若需处理文件打开失败的情况，可在Set sourceWB = ...前添加On Error Resume Next，并在后续判断sourceWB是否打开成功

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