■

Sub CopyDataFromReadOnlyFolder()
    Dim FolderPath As String
    Dim FileName As String
    Dim ExcelApp As Object
    Dim SourceWorkbook As Workbook
    Dim TargetSheet As Worksheet
    
    ' フォルダのパスを指定します
    FolderPath = "C:\Path\To\Your\ReadOnly\Folder\"
    
    ' フォルダ内の最初のExcelファイルを取得します
    FileName = Dir(FolderPath & "*.xlsx")
    
    ' Excelアプリケーションを作成します
    Set ExcelApp = CreateObject("Excel.Application")
    
    If FileName <> "" Then
        ' Excelファイルを開きます（読み取り専用モード）
        Set SourceWorkbook = ExcelApp.Workbooks.Open(FolderPath & FileName, ReadOnly:=True)
        
        ' シート3を取得します（thisworksheetを適切なシート名に変更してください）
        Set TargetSheet = ThisWorkbook.Sheets("thisworksheet") ' thisworksheetを適切なシート名に変更
        
        ' データをコピーして貼り付けます
        ' シート1からシート3へのコピー
        SourceWorkbook.Sheets(1).Range("A1").Copy Destination:=TargetSheet.Range("A1")
        SourceWorkbook.Sheets(1).Range("B2").Copy Destination:=TargetSheet.Range("A2")
        SourceWorkbook.Sheets(1).Range("C3").Copy Destination:=TargetSheet.Range("A3")
        
        ' シート2からシート3へのコピー
        SourceWorkbook.Sheets(2).Range("B1").Copy Destination:=TargetSheet.Range("D1")
        SourceWorkbook.Sheets(2).Range("B2").Copy Destination:=TargetSheet.Range("G2")
        SourceWorkbook.Sheets(2).Range("B3").Copy Destination:=TargetSheet.Range("D3")
        
        ' Excelファイルを閉じます
        SourceWorkbook.Close SaveChanges:=False ' 変更を保存しない
        
        ' Excelアプリケーションを終了します
        ExcelApp.Quit
    Else
        MsgBox "指定したフォルダ内にExcelファイルが見つかりませんでした。", vbExclamation
    End If
    
    ' オブジェクトを解放します
    Set SourceWorkbook = Nothing
    Set TargetSheet = Nothing
    Set ExcelApp = Nothing
End Sub