Question

我有29个文件需要不断更新。所有这些文件都在同一个文件夹中。我有另一个包含29个excel文件的文件夹（这些文件每周都会被提取）。所有这些文件都在同一个文件夹中（文件夹2）对于要更新的每个Excel文件，我需要在文件夹2中搜索具有相同名称的Excel文件，将工作表（＆＃34; Sheet 1＆＃34;）复制到我要更新的Excel文件中。以下是我的代码。当我运行代码时，我收到一条消息＆＃34;运行时错误＃5＆＃34; 谢谢你的帮助

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

如果两个目录中的文件名相同，则只需要一个Dir。（因为，一旦你知道一个文件名，你也知道另一个目录中的相应文件名 - 它是一样的。）

但是，您会遇到问题，因为如果Excel具有相同的文件名，则不能同时打开两个工作簿 - 您需要：

暂时给他们不同的名字（就像我在下面的代码中所做的那样）或
首先在一个文件中执行所有处理，然后关闭它并打开另一个文件，然后在该文件中执行所有处理。

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

下面的代码处理文件在"extract_xxx_date.xls"目录中命名为Repi但在"Suivi_xxx_MM.xls"目录中命名为Reps的情况：

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

使用两个Dir VBA

1 个答案: