如何将未打开的XLSX文件中某工作簿的区域值复制到新工作簿单列？

核心思路 #

要处理未打开的文件，需用Workbooks.Open方法逐个打开源文件，提取指定单元格区域的值后关闭，同时把这些值依次写入目标工作簿的单个列中，替代手动逐个操作的低效方式。

完整代码示例 #

Sub ExtractToSingleColumn()
    Dim targetWb As Workbook
    Dim sourceWb As Workbook
    Dim sourceWs As Worksheet
    Dim targetWs As Worksheet
    Dim fileFolder As String
    Dim fileName As String
    Dim nextRow As Long
    Dim extractRanges As Variant
    Dim rng As Variant
    
    ' 设置目标工作簿（用当前运行代码的工作簿，也可新建：Set targetWb = Workbooks.Add）
    Set targetWb = ThisWorkbook
    Set targetWs = targetWb.Worksheets("目标工作表") ' 替换为你的目标工作表名称
    nextRow = 1 ' 从第1行开始写入数据
    
    ' 设置要提取的单元格区域（可按需修改，支持单个单元格、连续/不连续区域）
    extractRanges = Array("A4", "B10", "C7") ' 示例：提取这几个单元格的值
    
    ' 设置源文件所在文件夹路径（末尾必须加\）
    fileFolder = "C:\你的文件存放路径\" ' 替换为实际文件夹路径
    
    ' 遍历文件夹下所有XLSX文件
    fileName = Dir(fileFolder & "*.xlsx")
    Do While fileName <> ""
        ' 打开源文件（只读模式避免锁定，关闭链接更新弹窗）
        Set sourceWb = Workbooks.Open(fileFolder & fileName, ReadOnly:=True, UpdateLinks:=False)
        Set sourceWs = sourceWb.Worksheets("Sheet1") ' 替换为源文件的目标工作表名称
        
        ' 遍历要提取的每个区域，写入目标单列
        For Each rng In extractRanges
            targetWs.Cells(nextRow, 1).Value = sourceWs.Range(rng).Value ' 写入第1列，改列号可切换目标列
            nextRow = nextRow + 1
        Next rng
        
        ' 关闭源文件，不保存修改
        sourceWb.Close SaveChanges:=False
        fileName = Dir() ' 获取下一个文件
    Loop
    
    MsgBox "提取完成！"
End Sub

关键说明 #

• 文件夹路径：必须替换为存放未打开XLSX文件的实际路径，末尾需保留反斜杠\。
• 提取区域：extractRanges数组可灵活修改，支持单个单元格（如"A4"）、连续区域（如"A1:C5"）；若提取连续区域，需额外循环区域内单元格写入单列。
• 目标位置：代码默认写入目标工作表第1列，若要切换列，修改Cells(nextRow, 1)中的1为对应列号（如2代表B列）。
• 性能优化：可在代码开头添加Application.ScreenUpdating = False，结尾添加Application.ScreenUpdating = True，避免屏幕闪烁，提升运行速度。

对原示例代码的优化点 #

原代码仅针对已打开的单个文件操作，适配未打开的多个文件时，核心是加入Dir函数遍历文件列表，用Workbooks.Open批量打开源文件，循环处理每个文件的指定区域，最终统一写入目标单列。

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