Excel VBA - 访问多个未打开的工作簿以提取单个单元格的信息

Question

并提前感谢你。

一些背景： - 我有一个包含大量.xls文件的文件夹，这些是引号 - 我需要从列“H”中的单元格中收集单元格信息，但行号将根据行是否已删除或添加到相关行上方而有所不同 - 与我想要检索的信息在同一行上的“F”上的两列，是每张表上的“SUB TOTAL”字样

我发现以下代码对我来说非常有用，但是Range设置了-Code并感谢Ron de Bruin。

    ub Summary_cells_from_Different_Workbooks_2()
    'This example use the function LastRow
    Dim FileNameXls As Variant
    Dim SummWks As Worksheet
    Dim ColNum As Integer
    Dim myCell As Range, Rng As Range, fndFileName As Range
    Dim RwNum As Long, FNum As Long, FinalSlash As Long
    Dim ShName As String, PathStr As String
    Dim SheetCheck As String, JustFileName As String
    Dim JustFolder As String


ShName = "Sheet1"  
Set Rng = Range("A1,D5:E5,Z10")    '<---- This is the bit I need to Change to make into a Find("SUB TOTAL").Offset(, 2)

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
                                          MultiSelect:=True)

If IsArray(FileNameXls) = False Then
    'do nothing
Else
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Use this sheet for the Summary
    Set SummWks = Sheets("Sheet2")    

    For FNum = LBound(FileNameXls) To UBound(FileNameXls)
        ColNum = 1
        RwNum = LastRow(SummWks) + 1
        FinalSlash = InStrRev(FileNameXls(FNum), "\")
        JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
        JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

        'If the workbook name already exist the row color will be Blue
        Set fndFileName = Nothing
        Set fndFileName = SummWks.Cells.Find(JustFileName)
        If Not fndFileName Is Nothing Then
            SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
                    .Interior.Color = vbBlue
        Else
            'Do nothing
        End If

        'copy the workbook name in column A
        SummWks.Cells(RwNum, 1).Value = JustFileName

        'build the formula string
        JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
        PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
                & ShName & "'!"

        On Error Resume Next
        SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
                                        .Address(, , xlR1C1))
        If Err.Number <> 0 Then
            'If the sheet name not exist the row color will be Yellow.
            SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
                    .Interior.Color = vbYellow
        Else
            'Insert the formulas
            For Each myCell In Rng.Cells
                ColNum = ColNum + 1
                SummWks.Cells(RwNum, ColNum).Formula = "=" _
                                                     & PathStr & myCell.Address
            Next myCell
        End If
        On Error GoTo 0
    Next FNum

    ' Use AutoFit to set the column width
    SummWks.UsedRange.Columns.AutoFit

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

正如您所看到的，我需要Range（Rng）作为代码才能在每个工作簿中找到正确的单元格。我尝试了很多变化，我不是很擅长VBA（我几乎把一些代码复制并粘贴在一起，以便从论坛这样的大部分时间里做出我需要的东西:)）

所以，如果有人能提供帮助，我将非常感激。