Excel VBA批量提取优化：多文件非连续数据采集与行偏移问题

问题1：提取指定非连续单元格或动态读取采集目标 #

方法1：直接指定非连续单元格 #

如果采集目标是固定的非连续单元格（如D11、D17、D19），可直接通过Range对象批量读取：

' 定义目标单元格地址（非连续用逗号分隔）
Dim targetRanges As String
targetRanges = "D11,D17,D19"

' 打开目标文件并读取指定工作表数据（替换为你的目标工作表名）
Dim sourceSheet As Worksheet
Set sourceSheet = Workbooks.Open(filePath).Worksheets("模板")

' 读取所有目标单元格值到数组
Dim dataArr As Variant
dataArr = sourceSheet.Range(targetRanges).Value

' 关闭源文件（不保存）
sourceSheet.Parent.Close SaveChanges:=False

方法2：从工作表动态读取坐标列表 #

若需灵活调整采集目标，可在跟踪器的"配置"工作表中维护坐标列表（如A列存储D11、D17等地址），代码自动读取：

' 读取配置表中的坐标列表（A列从A2开始，直到空行）
Dim configSheet As Worksheet
Set configSheet = ThisWorkbook.Worksheets("配置")

Dim lastRow As Long, i As Long
lastRow = configSheet.Cells(configSheet.Rows.Count, "A").End(xlUp).Row

' 存储所有目标地址
Dim targetAddresses() As String
ReDim targetAddresses(1 To lastRow - 1)

For i = 2 To lastRow
    targetAddresses(i - 1) = configSheet.Cells(i, "A").Value
Next i

' 拼接为Range可用的字符串
Dim targetRanges As String
targetRanges = Join(targetAddresses, ",")

' 后续读取逻辑同方法1

问题2：行偏移存储多组数据 #

通过维护当前写入行号变量，每处理完一个文件就偏移行号，实现数据依次存储。完整整合代码：

Sub BatchCollectYNStatus()
    ' 选择多个待采集的Excel文件
    Dim filePaths As Variant
    filePaths = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xlsx;*.xls), *.xlsx;*.xls", MultiSelect:=True)
    If IsArray(filePaths) = False Then Exit Sub ' 用户取消选择
    
    ' 初始化采集结果的写入起始行（写入到"采集结果"工作表，从最后一行下一行开始）
    Dim resultSheet As Worksheet
    Set resultSheet = ThisWorkbook.Worksheets("采集结果")
    Dim currentRow As Long
    currentRow = resultSheet.Cells(resultSheet.Rows.Count, "A").End(xlUp).Row + 1
    
    ' 定义采集目标（可替换为方法2的动态读取逻辑）
    Dim targetRanges As String
    targetRanges = "D11,D17,D19"
    
    ' 循环处理每个文件
    Dim i As Long
    For i = LBound(filePaths) To UBound(filePaths)
        Dim sourceWB As Workbook
        Set sourceWB = Workbooks.Open(filePaths(i), ReadOnly:=True)
        Dim sourceSheet As Worksheet
        Set sourceSheet = sourceWB.Worksheets("模板") ' 替换为你的目标工作表名
        
        ' 读取目标单元格数据
        Dim dataArr As Variant
        dataArr = sourceSheet.Range(targetRanges).Value
        
        ' 横向写入一行数据
        resultSheet.Cells(currentRow, "A").Resize(1, UBound(dataArr, 1)).Value = Application.Transpose(dataArr)
        ' 可选：记录源文件名到D列
        resultSheet.Cells(currentRow, "D").Value = sourceWB.Name
        
        ' 关闭源文件
        sourceWB.Close SaveChanges:=False
        
        ' 行号偏移，准备下一组数据写入
        currentRow = currentRow + 1
    Next i
    
    MsgBox "批量采集完成！"
End Sub

关键说明 #

• currentRow变量实时记录当前写入位置，每处理一个文件自动+1，确保数据不覆盖。
• 用Resize和Transpose将纵向读取的单元格值转为横向写入一行，适配多组数据的存储格式。
• 以只读模式打开源文件，避免文件锁定，提升处理效率。

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