Microsoft Access 掲示板

Rng1 = Sheets(1).Cells(1, 1)
Rng2 = Sheets(1).Cells(1, 3)
Rng3 = Sheets(1).Cells(4, 1)
Rng4 = Sheets(1).Cells(4, 3)
を
Rng1 = ExApp.Sheets(1).Cells(1, 1)
Rng2 = ExApp.Sheets(1).Cells(1, 3)
Rng3 = ExApp.Sheets(1).Cells(4, 1)
Rng4 = ExApp.Sheets(1).Cells(4, 3)
でどうでしょうか？

Set WSH = CreateObject("Wscript.Shell") は不要(使っていないなので)
開いたブックは変数に代入しておいて、それに対して操作する。
Set ExApp = Nothing はなくてもOK、End Sub で自動で Nothing にしてくれるので。

以上の点を考慮して修正すると下記になります。

Sub Test()

    Dim ExApp As Object
    Set ExApp = CreateObject("Excel.Application")
    ExApp.Visible = True '正常動作確認後、削除してもOK
    
    Dim DesktopPath As String, FilePath As String
    FolderPath = "C:\アクセス\エクセル"
    FilePath = FolderPath & "\エクセル操作.xlsx"

    Dim Rng1 As String
    Dim Rng2 As String
    Dim Rng3 As String
    Dim Rng4 As String
    Dim wb As Object

    Set wb = ExApp.Workbooks.Open(FileName:=FilePath) '開いたブックを変数に代入
    Rng1 = wb.Sheets(1).Cells(1, 1)
    Rng2 = wb.Sheets(1).Cells(1, 3)
    Rng3 = wb.Sheets(1).Cells(4, 1)
    Rng4 = wb.Sheets(1).Cells(4, 3)
    wb.Close '開いたブックを閉じる
    ExApp.Quit 'エクセルを閉じる

    CurrentDb.Execute "insert into T1(f1,f2,f3,f4) VALUES('" & Rng1 & "','" & Rng2 & "','" & Rng3 & "','" & Rng4 & "');", dbFailOnError

End Sub

Ayameさん、hatenaさんご指摘ありがとうございます。
教えていただいた内容で、エラーが出なくなりました。シートも選択できるように修正してみました。
前回教えていただいたコードも組み合わせてなんとか複数ファイルを取り込んで、フォルダを移動させることができていると思われますが、確認していただけないでしょうか。

Private Sub コマンド5_Click()
 Dim dname As String
     Dim destinationFolder As String
    dname = "C:\アクセス\エクセル\"
    destinationFolder = "C:\アクセス\エクセル\処理済\"
    Dim FSO As New Scripting.FileSystemObject
    Dim fl As Folder
    Set fl = FSO.GetFolder(dname)                ' フォルダを取得

    On Error Resume Next 'エラーが発生した場合無視して次の行へ
    Dim f As File
    For Each f In fl.Files                       'フォルダ内のファイルを取得
        If FSO.GetExtensionName(f.Path) = "xlsx" Then '拡張子がxlsxのファイル

    Dim ExApp As Object
    Set ExApp = CreateObject("Excel.Application")
    ExApp.Visible = False '正常動作確認後、削除してもOK
    Dim DesktopPath As String, FilePath As String


    Dim Rng1 As String
    Dim Rng2 As String
    Dim Rng3 As String
    Dim Rng4 As String
    Dim wb As Object

    Set wb = ExApp.Workbooks.Open(FileName:=f.Path) '開いたブックを変数に代入

    Rng1 = wb.Worksheets("Sheet1").Cells(1, 1)
    Rng2 = wb.Worksheets("Sheet1").Cells(1, 3)
    Rng3 = wb.Worksheets("Sheet1").Cells(4, 1)
    Rng4 = wb.Worksheets("Sheet1").Cells(4, 3)

    wb.Close '開いたブックを閉じる
    ExApp.Quit 'エクセルを閉じる

    CurrentDb.Execute "insert into T1(f1,f2,f3,f4) VALUES('" & Rng1 & "','" & Rng2 & _
                                "','" & Rng3 & "','" & Rng4 & "');", dbFailOnError
    
            If Err.Number = 0 Then               'エラーなくインポートされた
                    CurrentDb.Execute "UPDATE T1 SET ファイル名 = '" & f.Name & "'" & _
                              " WHERE ファイル名 Is Null;", dbFailOnError
               FSO.MoveFile f.Path, destinationFolder 'ファイル移動
            End If
            If Err.Number <> 0 Then 'エラー発生
                'とりあえずイミディエイトにファイル名、エラーメッセージを出力
            Debug.Print f.Name & " " & Err.Number & ":" & Err.Description
                CurrentDb.Execute "insert into T3(ファイル名,エラー番号,エラー内容) VALUES('" & f.Name & "','" & Err.Number & _
                                "',""'" & Err.Description & "'"");", dbFailOnError
            
            Err.Clear
            End If
    
    
        End If
    Next
    On Error GoTo 0 'エラー処理を無効にする
    Set FSO = Nothing

End Sub

どうぞよろしくお願いします。

上げさせていただいたコードだと、エラーが発生したときに、ブランクのレコードができてしまったので、

 If Err.Number = 0 Then

の位置を

 CurrentDb.Execute "insert into T1(f1,f2,f3,f4) VALUES('" & Rng1 & "','" & Rng2 & _
                                "','" & Rng3 & "','" & Rng4 & "');", dbFailOnError

の前に変えたらうまくいったようです。