2つのDir VBAの使用

Question

私は継続的に更新する必要がある29個のファイルがあります。これらのファイルはすべて同じフォルダにあります。 29個のExcelファイルがある別のフォルダがあります（これらのファイルは毎週抽出されます）。これらのファイルはすべて同じフォルダ（フォルダ2）にあります 更新するExcelファイルごとに、同じ名前のExcelファイルを検索する必要があります。フォルダ2では、ワークシート（「シート1」）を更新されるExcelファイル。 以下は私のコードです。 私は、コードを実行すると、私はメッセージ「ランタイムエラーの＃5」を取得 、2つのディレクトリ内のファイル名が同一である場合にのみ、1 Dirを持っている必要がありますする必要があり、あなたの助け

Option Explicit 

Public Sub ChoixRep() 

Dim fd As FileDialog 
Dim Reps As String 
Dim Repi As String 

MsgBox "Choisir le dossier des fichiers de suivi DD" 
    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'création d'une boite de dialogue choix de répertoire 
    fd.AllowMultiSelect = False 'on ne peut choisir qu'un seul repertoire 
    If fd.Show = -1 Then 'l'utilisateur à valider sa selection 
     Reps = fd.SelectedItems(1) 'le repertoire choisi 
     'Boucle repertoire 
    End If 

MsgBox "Choisir le reportoire des fichiers à importer" 

    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'création d'une boite de dialogue choix de répertoire 
    fd.AllowMultiSelect = False 'on ne peut choisir qu'un seul repertoire 
    If fd.Show = -1 Then 'l'utilisateur à valider sa selection 
     Repi = fd.SelectedItems(1) 'le repertoire choisi 
    End If 
doubleboucle Reps, Repi 
End Sub 

Private Sub doubleboucle(ByVal Reps As String, Repi As String) 

Dim FichierS As String 
Dim FichierI As String 
Dim Ws As Workbook 
Dim Wi As Workbook 

FichierS = Dir(Reps & "\*.xls") 'je pense qu'on peut enlever .xls 
FichierI = Dir(Repi & "\*.xls") 'je pense qu'on peut enlever .xls 

Do While FichierS <> "" 
    Set Ws = Workbooks.Open(Reps & "\" & FichierS) 
     Do While FichierI <> "" 
      Set Wi = Workbooks.Open(Repi & "\" & FichierI) 
      If Ws.Name = Wi.Name Then 
       Traitement Ws, Wi 
      End If 
      Wi.Save 
      Wi.Close 
      FichierI = Dir 
     Loop 
    Ws.Save 
    Ws.Close 
    FichierS = Dir 
Loop 

End Sub 

Private Sub Traitement(ByRef Ws As Workbook, Wi As Workbook) 

Wi.Worksheets("Feuil1").Cells.Copy Ws.Add.Range("A1") 
ActiveSheet.Move After:=Worksheets(Worksheets.Count) 
Application.CutCopyMode = False 'Pour eviter d'avoir le message du presse papier à garder 

End Sub 

Answer 1

いただきありがとうございます。 （1つのファイル名が分かれば、別のディレクトリの対応するファイル名も知っているので、それは同じです）

Excelは2つのブックを同時に開くことができないため、

一時的にそれらに異なる名前を与える（私は以下のコードでそうであるように）、または

• それを閉じて、開いて、最初の一つのファイルにすべての処理を行います。あなたはどちらかにする必要があります - 彼らは同じファイル名を持ちますもう一方は、そのファイルのすべての処理を行います。

Option Explicit 

Public Sub ChoixRep() 

    Dim fd As FileDialog 
    Dim Reps As String 
    Dim Repi As String 

    MsgBox "Choisir le dossier des fichiers de suivi DD" 
    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'création d'une boite de dialogue choix de répertoire 
    fd.AllowMultiSelect = False 'on ne peut choisir qu'un seul repertoire 
    If fd.Show = -1 Then 'l'utilisateur à valider sa selection 
     Reps = fd.SelectedItems(1) 'le repertoire choisi 
     'Boucle repertoire 
    End If 

    MsgBox "Choisir le reportoire des fichiers à importer" 

    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'création d'une boite de dialogue choix de répertoire 
    fd.AllowMultiSelect = False 'on ne peut choisir qu'un seul repertoire 
    If fd.Show = -1 Then 'l'utilisateur à valider sa selection 
     Repi = fd.SelectedItems(1) 'le repertoire choisi 
    End If 
    doubleboucle Reps, Repi 
End Sub 

Private Sub doubleboucle(ByVal Reps As String, Repi As String) 

    Dim Fichier As String 
    Dim Ws As Workbook 
    Dim Wi As Workbook 

    Fichier = Dir(Reps & "\*.xls") 'je pense qu'on peut enlever .xls 

    Do While Fichier <> "" 
     'Create a dummy copy of one of the files 
     FileCopy Repi & "\" & Fichier, Repi & "\DUMMY_" & Fichier 
     'open the two files 
     Set Wi = Workbooks.Open(Repi & "\DUMMY_" & Fichier) 
     Set Ws = Workbooks.Open(Reps & "\" & Fichier) 
     'process 
     Traitement Ws, Wi 
     'Save and close the changed workbook 
     Ws.Save 
     Ws.Close 
     'close the unchanged workbook 
     Wi.Close False 'Don't save changes (nothing was changed) 
     'kill the dummy file 
     Kill Repi & "\DUMMY_" & Fichier 
     'Look for the next file to process 
     Fichier = Dir 
    Loop 

End Sub 

Private Sub Traitement(ByRef Ws As Workbook, Wi As Workbook) 
    'Note: "Ws.Add" won't work as a Workbook does not have an Add method. 
    '  I changed it to be "Ws.Worksheets.Add" on the assumption that you are 
    '  trying to create a new worksheet. 
    Wi.Worksheets("Feuil1").Cells.Copy Ws.Worksheets.Add.Range("A1") 
    ActiveSheet.Move After:=Worksheets(Worksheets.Count) 
    Application.CutCopyMode = False 'Pour eviter d'avoir le message du presse papier à garder 

End Sub 

---

次のコードは、ファイルがRepiディレクトリ内"extract_xxx_date.xls"という名前が、Repsディレクトリに"Suivi_xxx_MM.xls"命名されている場合に処理します。

Option Explicit 

Public Sub ChoixRep() 

    Dim fd As FileDialog 
    Dim Reps As String 
    Dim Repi As String 

    MsgBox "Choisir le dossier des fichiers de suivi DD" 
    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'création d'une boite de dialogue choix de répertoire 
    fd.AllowMultiSelect = False 'on ne peut choisir qu'un seul repertoire 
    If fd.Show = -1 Then 'l'utilisateur à valider sa selection 
     Reps = fd.SelectedItems(1) 'le repertoire choisi 
     'Boucle repertoire 
    End If 

    MsgBox "Choisir le reportoire des fichiers à importer" 

    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'création d'une boite de dialogue choix de répertoire 
    fd.AllowMultiSelect = False 'on ne peut choisir qu'un seul repertoire 
    If fd.Show = -1 Then 'l'utilisateur à valider sa selection 
     Repi = fd.SelectedItems(1) 'le repertoire choisi 
    End If 
    doubleboucle Reps, Repi 
End Sub 

Private Sub doubleboucle(ByVal Reps As String, Repi As String) 

    Dim FichierI As String 
    Dim FichierS As String 
    Dim Ws As Workbook 
    Dim Wi As Workbook 

    FichierS = Dir(Reps & "\*.xls") 'je pense qu'on peut enlever .xls 

    Do While FichierS <> "" 
     'Generate name of file in Repi directory 
     FichierI = "extract_" & Split(FichierS, "_")(1) & "_date.xls" 
     'open the two files 
     Set Wi = Workbooks.Open(Repi & "\" & FichierI) 
     Set Ws = Workbooks.Open(Reps & "\" & FichierS) 
     'process 
     Traitement Ws, Wi 
     'Save and close the changed workbook 
     Ws.Save 
     Ws.Close 
     'close the unchanged workbook 
     Wi.Close False 'Don't save changes (nothing was changed) 

     'Look for the next file to process 
     FichierS = Dir 
    Loop 

End Sub 

Private Sub Traitement(ByRef Ws As Workbook, Wi As Workbook) 
    'Note: "Ws.Add" won't work as a Workbook does not have an Add method. 
    '  I changed it to be "Ws.Worksheets.Add" on the assumption that you are 
    '  trying to create a new worksheet. 
    Wi.Worksheets("Feuil1").Cells.Copy Ws.Worksheets.Add.Range("A1") 
    ActiveSheet.Move After:=Worksheets(Worksheets.Count) 
    Application.CutCopyMode = False 'Pour eviter d'avoir le message du presse papier à garder 

End Sub