フォルダ内のすべてのファイルにコピーして貼り付けます

Question

1つのファイルからシートをコピーし、確立されたフォルダ内の約6つのファイルにある確立されたタブに貼り付けようとしています。私はこのコードを持っていますが、フォルダ内の最初のファイルに対してのみ動作します。何らかの理由で空のワークブックを作成しています。助言がありますか？

Sub LoopThroughFiles() 

Dim wbk As Workbook 
Dim Filename As String 
Dim FirstFile As String 
Dim FileDirectory As String 
Dim x As Workbook 

Set x = Workbooks.Open("test.xlsx") 


With Application.FileDialog(msoFileDialogFolderPicker) 

    .Title = "Please select a folder" 
    .AllowMultiSelect = False 
    .Show 

    If .SelectedItems.Count = 0 Then 
     MsgBox "You did not select a folder" 
     Exit Sub 
    Else 
     FileDirectory = .SelectedItems(1) & "\" 
    End If 

End With 

Set wbk = Workbooks.Add 


Filename = Dir(FileDirectory) 
FirstFile = Filename 



Do Until Filename = "" 

    Dim new_wb As Workbook 
Set new_wb = Workbooks.Open(FileDirectory & Filename) 



If FirstFile = Filename Then 

    x.Sheets("report").UsedRange.Copy 

    new_wb.Sheets("roster").Range("a1").PasteSpecial 




End If 


new_wb.Close savechanges:=True 
Filename = Dir 

Loop 

MsgBox "All store totals have been added" 

End Sub 

Answer 1

サブLoopThroughFiles_Paste_Roster（）ワークブック「新しいブックとしてデータブック 暗いYとして文字列 暗いXと文字列 暗いFileDirectoryとして文字列 暗いFirstFileよう 暗いファイル名に付加されるWBK

薄暗いですブックとして

セットX = Workbooks.Open（ "コピードク1"） 集合Y = Workbooks.Open（ "コピードク2"）

「

を持つユーザがApplication.FileDialog（msoFileDialogFolderPicker）でフォルダ を選択できるように

.Title = "Please select a folder" 
.AllowMultiSelect = False 
.Show 

If .SelectedItems.Count = 0 Then 
    MsgBox "You did not select a folder" 
    Exit Sub 
Else 
    FileDirectory = .SelectedItems(1) & "\" 
End If 

をフォルダ選択ダイアログボックスを表示エンド」

監督 を使用して、フォルダ内の最初のファイルの名前を取得ファイル名= DIR（FileDirectory） FirstFile =ファイル名

'ループフォルダ 内のすべてのファイルを通じて' ファイルを開く

いますファイル名= ""

セットWBK = Workbooks.Open（FileDirectory &ファイル名、UpdateLinks：= Falseを、パスワード：= "Password123"）まで

With wbk 

    x.Sheets("report").UsedRange.Copy 

    wbk.Sheets("roster").Range("a1").PasteSpecial 

    y.Sheets("Setup").UsedRange.Copy 

    wbk.Sheets("PTO Taken and Req").Range("a1").PasteSpecial 


    End With 

'ファイルを保存して閉じ 'フォルダ wbk.CloseのSaveChangesメソッドで次のファイルを取得する：= Trueの ファイル名= DIR

ループ

のMsgBox「すべてをページは

End Subの「更新されている