有點複雜有些地方可能理解錯誤。

問題

優化檔案開啟速度
有三張資料表
表A：來源資料表
表B：搜尋
表C：搜尋結果

在表A搜尋表B，產出結果表C。

解決方法

用公式查到值以後 > 選擇性貼上/值

Sub 跨資料表查詢()

'宣告
    '資料表設定：表A,表B,表C
    Dim shA, shB, shC, fml As String
    shA = "A"
    shB = "A"
    shC = "A"

    '公式設定
    fml = "=INDEX($B$5:$B$9,MATCH(F5,$C$5:$C$9)+1,1)"
    
    '輸出範圍
    Set result = Sheets(shC).Range("I5: J7")
    
'處理過程
    endRow = result.Rows.Count
    result.Rows(1).Formula = fml
    
    For reRow = 2 To endRow
        result.Rows(1).Copy
        
        With result.Rows(reRow)
        .PasteSpecial
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        End With
    Next reRow
    
    With result.Rows(1)
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With
    
End Sub

其實寫法很多種, 我也不是很熟, 我用最笨的寫法,
"來杯拿鐵"的比較符合你要的答案, 我是來串門子練功夫

還有一種做法是, 寫深一點, 程式寫在A活頁簿, 然後指定路徑+檔名, 去執行

Sub MAIN()

Dim rng As Object '物件
Dim dataRow As Integer '表B 的資料列數
Dim dataCol As Integer '表B 的資料欄數
Dim xRow As Integer '表B列, 用來循序讀取列資料
Dim xCol As Integer '表B欄, 用來循序移動欄座標讀取資料
Dim fData As Double '要比對的表B值
Dim fRow As Integer '比對表A值, 符合條件的列數
Dim dataEnd As Integer '表A 的資料列數
Dim cRow As Integer '要寫入表C 的列的位置

Application.ScreenUpdating = False ' 關閉螢幕的顯示

'--------------------------------------------------
'填入表C 的標題列, 有點多餘, 看你要不要用
Worksheets("表C").Range("A1").Value = "1A"
Worksheets("表C").Range("B1").Value = "1B"
Worksheets("表C").Range("C1").Value = "1C"
Worksheets("表C").Range("D1").Value = "1D"
Worksheets("表C").Range("E1").Value = "1E"
'--------------------------------------------------

' 切換到表A, 取得最後的資料列位置
Worksheets("表A").Activate
dataEnd = Cells(ActiveSheet.Rows.Count, "D").End(xlUp).Row

' 切換到表B 最後的資料列及欄位數
Worksheets("表B").Activate
dataRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row ' 取得資料最後列
dataCol = Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column ' 取得資料最右欄

For xCol = 1 To dataCol '表B 欄
    cRow = 1 '表C 的欄題列值, 0表示沒有標題列
    For xRow = 1 To dataRow ' 表B 列
        ' 取得表B RANGE(A1~A最後列)的值, CELLS(列, 欄), 例 CELLS(1, "A") = A1 或 CELLS(1,1) = A1
        fData = Worksheets("表B").Cells(xRow, xCol).Value

        ' 開始比對資料
        Worksheets("表A").Activate
        For Each rng In Range("D2:D" & dataEnd)
        
            If rng.Text > fData Then
               fRow = rng.Row ' 符合比對條件的資料列數值
               cRow = cRow + 1 ' 寫入表C的列數值
               ' 把指定的表A值填入表C
               Worksheets("表C").Cells(cRow, xCol).Value = Worksheets("表A").Cells(fRow, "A").Value
               Exit For '結束此次比對
            End If
        Next
        
        Worksheets("表B").Activate
    Next xRow
Next xCol

Application.ScreenUpdating = True

End Sub