使用两个Dir VBA
我有29个文件，我需要不断更新。 所有这些文件都在同一个文件夹中。 我有另外一个有29个excel文件的文件夹（每周提取这些文件）。 所有这些文件都在同一个文件夹中（文件夹2）对于每个要更新的Excel文件，我需要search具有相同名称的Excel文件，在文件夹2中将工作表（“Sheet 1”）复制到我的Excel中文件被更新。 以下是我的代码。 当我运行代码时，我收到一条消息“运行时错误＃5”谢谢你的帮助
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 如果两个目录中的文件名相同，则只需要一个Dir 。 （因为，一旦你知道一个文件名，你也知道在另一个目录中相应的文件名 – 这是相同的。）
但是，您将遇到问题，因为如果Excel具有相同的文件名，则不能同时打开两个工作簿 – 您将需要：
- 暂时给他们不同的名字（如我在下面的代码中）或者
- 首先在一个文件中完成所有的处理，然后closures它并打开另一个文件，然后在该文件中进行所有的处理。
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
以下代码处理"Suivi_xxx_MM.xls"目录中文件名为"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