从多个工作表中提取不连续的数据，同时从循环的列表中提取

Question

我正在尝试制作一个跟踪器，其中有一个 Y/N 的集合模板，可以在此表单中输入。我想跟踪所有这些数据，例如。在所有文件的批量选择中跟踪这些工作表的所有状态的进度，而无需打开和关闭 30 次。

Sub ImportDataFromMultipleFiles()
Dim Filenames As Variant
Dim i As Integer
Dim copyrange As Range
Dim cellrange As Range

Application.ScreenUpdating = False 'keeps the screen from flickering true/false
ActiveSheet.Range("A1:A1000").Find("").Select 'where in the tracker the results will appear and the next empty cell, must have the header
Filenames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xls*),*xls*", Title:="Open Files(s)", MultiSelect:=True) 'selecting multiple files

'While loop outside for loop inside, list value in list
'logic is for each ubound file is selected, while each cell follows the list

'the below is a for loop to iterate within the excel sheet

For i = 1 To UBound(Filenames) 'selects all the MOCs ubound giving the position
Workbooks.Open Filenames(i) 'the selected filenames
ActiveWorkbook.Sheets(3).Range("H1").Copy 'the selected range from the selected folders, like D11 D17 D19
'Selection.Copy 'copying the selected values
Windows("tracker automated.xlsm").Activate 'Choosing the file destination
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True 'eventually change the pasting to just text only
Workbooks.Open Filenames(i) 'opening up the selected workbook
ActiveWorkbook.Close SaveChanges:=False 'does not make any edits to the MOC
ActiveCell.Offset(1, 0).Activate 'Offsetting the active cell by one after the filled cell, in the Y-axis

Next i
End Sub

此 VBA 代码从单元格“H1”中提取数据。

1. 我怎样才能包含更多单元格的选择，例如。 D11、D17、D19？
   最初的想法是在另一个工作表中创建一个坐标列表，并在我尝试复制的表单发生更改时分配所述单元格，例如 J43、J89，这意味着所有单元格都会发生巨大变化Y/N 的位置。

2. 如何继续偏移行中的数据？
   我想随着更多的“提取数据”，我需要一个 while/for 循环来继续将其余数据存储在行中。

大部分代码是从 YouTube 和其他来源复制和改编的。

Answer 1

例如：

Sub ImportDataFromMultipleFiles()
    Dim Filenames As Variant, wb As Workbook, i As Long, c As Range, arrSrc, n As Long
    
    Set c = ThisWorkbook.Worksheets("Data").Range("A1001").End(xlUp).Offset(1) 'next empty cell
    
    Filenames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xls*),*xls*", _
                                            Title:="Open Files(s)", MultiSelect:=True)
    If VarType(Filenames) = vbBoolean Then Exit Sub 'user cancelled?
    
    arrSrc = Array("H1", "D11", "D17", "D19") 'all source cells
    
    For i = 1 To UBound(Filenames)
        With Workbooks.Open(Filenames(i)) 'reference the opened file
            For n = 0 To UBound(arrSrc)  'loop over source cells
                c.Offset(i - 1, n).Value = .Sheets(3).Range(arrSrc(n)).Value 'write values directly to row
            Next n
            .Close False 'no save
        End With
    Next i
End Sub