特定のフォルダ内のファイルからワークシートをコピーする

Question

コンピュータの特定のフォルダにあるファイルからワークシートをコピーしようとしています。メインのワークブック（Workbook1）を持って、特定のフォルダ（C：\ Location）からすべてのxlsまたはxlsmファイルの1番目のシートを取るボタンを押したいと思います。現在私が持っているものは以下の通りです。

Sub read_a_folder() 

Dim MainWB As String 

strPath = "C:\Location\" 
MainWB = ActiveWorkbook.Name 

Set objFso = CreateObject("Scripting.FileSystemObject") 
Set objFolder = objFso.GetFolder(strPath) 

For Each objFile In objFolder.Files 

If objFso.GetExtensionName(objFile.Path) = "xls" Or objFso.GetExtensionName(objFile.Path) = "xlsm" Then 



End If 
Next 

End Sub 

私のメインブックにそのままコピーする方法がありません。私はActiveSheet.QueryTables.Addを使用しようとしましたが、コピーされたシートの特別なフォーマットでは判読できません。 Ctrl + Shift + EndとCtrl + Cは手動で行うと機能します。

助けが必要です。

ありがとうございます。

Answer 1

ちょうどDaveのコードをフォローアップするために、いくつかの機能強化（と一つの小さな改訂）で

Option Explicit 

Sub read_a_folder() 

    Dim objFso As FileSystemObject 
    Dim objFolder As Folder 
    Dim objFile As File 

    Dim MainWB As Workbook 
    Dim strPath As String 

    strPath = "C:\Location\" 

    Set MainWB = ActiveWorkbook '<~~ Workbook is an object -> you must "Set" it 

    Set objFso = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFso.GetFolder(strPath) 

    Application.ScreenUpdating = False '<~~ this will reduce the flickering and speed it all up 
    For Each objFile In objFolder.Files 
     If objFso.GetExtensionName(objFile.Path) Like "xls*" Then '<~~ use "Like" operator to check for all "xls..." extensions in a single check 
      With Workbooks.Open(objFile.Path, False, True) '<~~ no need to set an object, just instantiate it and work with it! Furthermore let's use some of the "Open" method parameters to avoid prompts popping out 
       .Worksheets(1).Copy After:=MainWB.Sheets(MainWB.Sheets.Count) 'copies after last worksheet 
       .Close False 
      End With 
     End If 
    Next 
    Application.ScreenUpdating = True '<~~ turn screen updating on 
End Sub 

Answer 2

以下が役立つことがあります。（！ - 彼に>クレジット）

Sub read_a_folder() 

Dim MainWB As Workbook 
Dim objSheet As Worksheet 

strPath = "C:\Location\" 
MainWB = ActiveWorkbook.Name 

Set objFso = CreateObject("Scripting.FileSystemObject") 
Set objFolder = objFso.GetFolder(strPath) 

For Each objFile In objFolder.Files 
    If objFso.GetExtensionName(objFile.Path) = "xls" Or objFso.GetExtensionName(objFile.Path) = "xlsm" Then 
     Set objWb = Workbooks.Open objFile.Path 
     Set objSheet = objWb.Worksheets(1) ' sets first sheet 
     objSheet.Copy After:=MainWB.Sheets(MainWB.Sheets.Count) 'copies after last worksheet 
     objWb.Close 
     Set objSheet = Nothing 
     Set objWb = Nothing 
    End If 
Next 

End Sub