遍历文件夹中以“vip”开头的所有 Excel 文件并运行另一个宏答案

【问题标题】：Loop through all Excel files starting with "vip" in Folder and run another Macro遍历文件夹中以“vip”开头的所有 Excel 文件并运行另一个宏
【发布时间】：2021-10-18 16:35:47
【问题描述】：

我以前做过很多循环，但由于某种原因，这个不起作用。我想在以“vip”开头的文件夹中查找所有 Excel 文件并运行另一个宏。第二个宏做了很多事情并将文件保存在另一个文件夹中（因此为什么当循环结束时，我会杀死所有剩余的文件）。

问题是当我运行循环时，找到了第一个文件，运行了第二个宏，但是当它循环时，它找不到第二个文件。我做了一个带有计数器的版本，但这并没有真正起作用。计数器可以找到我需要运行宏的三个文件，但是在启动第二个宏的循环时发生了同样的问题，它会找到第一个文件，而第二个文件将找不到。我什至尝试了一个循环打开所有 Excel 文件的版本，使用 IF 语句来查找要在哪些文件上运行宏以及要简单地关闭哪些文件，但我遇到了与其他两个版本完全相同的问题。

所以基本上，它会找到第一个文件，执行它必须执行的操作，循环然后给我错误 1004 消息，其中文件夹可能已被移动、重命名或删除。我被难住了。

感谢您的帮助！

这是我的代码（对不起法语的说法，但无论如何你应该明白代码的作用！）：

' Loop_pour_importation_Zoho
'
'Bloquer mise-à-jour visuelle
    Application.ScreenUpdating = False
    
'Bloquer les alertes
    Application.DisplayAlerts = False
    
'Loop pour mise en page de tous les fichiers Excel
    Dim VIP As String
    Dim Folder As String
    Dim Compte As Integer
    Dim CompteLoop As Integer
    
    Folder = "C:\Users\Raid\Desktop\RAID\Test\importation\"
    VIP = Dir(Folder & "vip*.xls*")

    Do While Len(VIP) > 0
        With Workbooks.Open(Folder & VIP)
            Call Module20.Mise_en_forme_Zoho
        End With
        VIP = Dir
    Loop

'Effacer les fichiers originaux
     Kill "C:\Users\Raid\Desktop\RAID\Test\importation\*.xls*"

'Réactiver mise-à-jour visuelle
    Application.ScreenUpdating = Vrai
    
'Réactiver les alertes
    Application.DisplayAlerts = Vrai

End Sub

Sub Mise_en_forme_Zoho()
'
' Mise_en_forme_Zoho Macro
'

'Nommer les variables

    Dim LastRow As Integer
    Dim Dossier As String
    Dim Document As String
    Dim RapportTraid As Workbook
    Dim Fichier As String
    Dim Liste As Workbook
    Dim DernLigne As Integer
    Dim ProchLigne As Integer
    Dim NextRow As Integer
    Dim Infos As Integer
    Dim CodeTel As Workbook
    Dim LigneFin As Integer
    Dim LigneSuite As Integer
        
'Définir le rapport à modifier

    Dossier = "C:\Users\Raid\Desktop\RAID\Test\importation\"
    Fichier = Dir(Dossier & "vip*.xls")
    
    Set Liste = Workbooks.Open(Dossier & Fichier)

'Compteur de lignes à partir de la colonne 1

    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

'Insérer et nommer les nouvelles colonnes

    Columns("A:S").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Source"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "code tel"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Phone"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Lead Status"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "start_date"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "end_date"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Offers"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Concessionnaire"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Semaine"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Event Date"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Email"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Brand/Marque"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "Model/Modèle"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "Year/Année"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "KM"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "marque"
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "model"
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "année"
    Range("S1").Select
    ActiveCell.FormulaR1C1 = "Last Name"
    
'Remplir les informations de base
    
    For i = 2 To LastRow
    
        Cells(i, 1).Select
        ActiveCell.FormulaR1C1 = "VP"
        Cells(i, 4).Select
        ActiveCell.FormulaR1C1 = "Imported"
        Cells(i, 3).Select
        ActiveCell.FormulaR1C1 = "=RC[24]"
        Cells(i, 11).Select
        ActiveCell.FormulaR1C1 = "=RC[22]"
        Cells(i, 16).Select
        ActiveCell.FormulaR1C1 = "=RC[18]"
        Cells(i, 17).Select
        ActiveCell.FormulaR1C1 = "=RC[18]"
        Cells(i, 18).Select
        ActiveCell.FormulaR1C1 = "=RC[18]"
        Cells(i, 19).Select
        ActiveCell.FormulaR1C1 = "=RC[6]&"" ""&RC[7]"
    
    Next i
    
'Ouvrir le rapport traid
    
    Range("U2").Select
    Selection.Copy
    
    Document = Dir(Dossier & "traid*.xls")
    
    Set RapportTraid = Workbooks.Open(Dossier & Document)
    
'Compter les lignes du rapport à partir de la ligne 1

    DernLigne = Cells(Rows.Count, 1).End(xlUp).Row
    ProchLigne = DernLigne + 1
    
'Trouver la ligne correspondant à l'événement

    Range("A" & ProchLigne).Activate
    Range("A" & ProchLigne).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    For i = 2 To DernLigne
    
        If Cells(i, 3).Value = Range("A" & ProchLigne) Then
            Range("A" & i & ":S" & i).Copy
            Liste.Activate
            NextRow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row
            Worksheets("vip").Activate
            Range("A" & NextRow & ":S" & NextRow).Activate
            Worksheets("vip").Select
            Range("A" & NextRow & ":S" & NextRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
        End If
        
    Next i

'Remplir les information du rapport Traid

    Infos = LastRow + 1
    
    For i = 2 To LastRow
    
        Cells(i, 5).Select
        ActiveCell.Value = Cells(Infos, 8)
        Cells(i, 7).Select
        ActiveCell.Value = Cells(Infos, 13)
        Cells(i, 8).Select
        ActiveCell.Value = Cells(Infos, 7)
    
    Next i

'Séparer le début et la fin de l'événement

    Columns("E:E").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        
'Remplir le numéro de la semaine

    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=ISOWEEKNUM(RC[-4])"
    
'Trouver le jour de la semaine

    Range("T" & Infos).Select
    ActiveCell.FormulaR1C1 = "=WEEKDAY(R2C[-15])"
    Range("U" & Infos).Select
    ActiveCell.FormulaR1C1 = "=WEEKDAY(R2C[-16])+1"
    Range("V" & Infos).Select
    ActiveCell.FormulaR1C1 = "=WEEKDAY(R2C[-16])"

'Changer le jour en nom

    Range("T52:V52").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Replace What:="1", Replacement:="Sunday", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="2", Replacement:="Monday", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="3", Replacement:="Tuesday", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="4", Replacement:="Wednesday", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="5", Replacement:="Thursday", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="6", Replacement:="Friday", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="7", Replacement:="Saturday", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

'Rentrer les jours dans Event Date

    Range("J" & Infos & ":J" & Infos).Select
    Selection.TextToColumns Destination:=Range("J52"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=Chr(10), FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

    Range("J3").Select
    ActiveCell.FormulaR1C1 = "=R" & Infos & "C[10]&RIGHT(R" & Infos & "C,LEN(R" & Infos & "C)-5)"
    Range("J4").Select
    ActiveCell.FormulaR1C1 = "=R" & Infos & "C[11]&RIGHT(R" & Infos & "C[1],LEN(R" & Infos & "C[1])-5)"
    Range("J5").Select
    ActiveCell.FormulaR1C1 = "=R" & Infos & "C[12]&RIGHT(R" & Infos & "C[2],LEN(R" & Infos & "C[2])-5)"
    Range("J2").Select
    ActiveCell.Value = Range("J3") & Chr(10) & Range("J4") & Chr(10) & Range("J5")

'Compléter les infos dans toutes les lignes

    For i = 3 To LastRow
        
        Cells(i, 9).Value = Cells(2, 9).Value
        Cells(i, 10).Value = Cells(2, 10).Value
    
    Next i
    
'Mise en forme générale

    Range("F1").Value = "end_date"
    
    Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
'Supprimer la ligne du rapport Traid dans Liste

    Rows(Infos).Select
    Selection.Delete Shift:=xlUp
    
'Supprimer le numéro de campagne du rapport Traid et fermer

    RapportTraid.Activate
    Rows(ProchLigne).Select
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Close
    
'Copier le nom du concessionnaire

    Liste.Activate
    Range("H2").Select
    Selection.Copy
    
'Ouvrir le rapport code de téléphonie

    Set CodeTel = Workbooks.Open("C:\Users\Raid\Desktop\RAID\Test\Macro TRaid\Code Tel.xlsx")
    CodeTel.Activate
    
'Compter les lignes de Code Tel à partir de la ligne 1

    LigneFin = Cells(Rows.Count, 1).End(xlUp).Row
    LigneSuite = LigneFin + 1
    
'Trouver la ligne correspondant au concessionnaire

    Range("A" & LigneSuite).Activate
    Range("A" & LigneSuite).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    For i = 1 To LigneFin
    
        If Cells(i, 1).Value = Range("A" & LigneSuite) Then
            Range("B" & i).Copy
        End If
        
    Next i
    
    Liste.Activate
    Worksheets("vip").Activate
    Range("B2").Activate
    Worksheets("vip").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Fermer Code Tel

    CodeTel.Activate
    Rows(LigneSuite).Select
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Close
    
'Remplir Liste avec Code Tel

    Liste.Activate
    Worksheets("vip").Activate
    
    For i = 3 To LastRow
        Cells(i, 2).Value = Cells(2, 2).Value
    Next i
    
    Columns("B:B").Select
    Selection.NumberFormat = "@"
    
'Sauvegarder, fermer et supprimer Liste

    ChDir "C:\Users\Raid\Desktop\RAID\Test\vers Zoho\"
    ActiveWorkbook.SaveAs Filename:= _
    Fichier, FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    Liste.Close
        
End Sub

【问题讨论】：

Mise_en_forme_Zoho 会发生什么？
@TimWilliams 一大堆东西。它打开“vip”Excel文件，添加列，用文件中已有的信息填充其中的一些，并用两个单独的Excel文件（一个在“文件夹”中，一个在其他地方不移动）的信息填充其余部分。然后保存文件并关闭它。代码太长，无法粘贴到这里。
你在那个方法中使用Dir()吗？如果您注释掉 Call 行，您的代码是否会打开文件夹中的每个工作簿？你说它“打开文件”但文件已经打开了？
@TimWilliams 不，Mise_en_forme_Zoho 不会打开 VIP 文件，只有循环会。 Mise_en_forme_Zoho 在与该模块中定义的 VIP 文件相同的文件夹中打开一个 Excel 报告，并在完成后将其关闭。它还会打开一个在模块中定义的参考 Excel 文件，并在完成后将其关闭。 Mise_en_forme_Zoho 关闭了 VIP 文件，我不应该这样做吗？
@TimWilliams 在 Mise_en_forme_Zoho 中，我不使用 Dir()。我定义目录来调用我需要的不同文件，但我不循环或类似的东西。

标签： excel vba for-loop

【解决方案1】：

尝试将您的子例程调用移到 Dir 循环之外。还将文件名传递给 sub。

    Folder = "C:\Users\Raid\Desktop\RAID\Test\importation\"
    VIP = Dir(Folder & "*.xls*")
    
    Dim myfiles As New Collection
    Do While Len(VIP) > 0
        myfiles.Add VIP
        VIP = Dir
    Loop

    For Each VIP In myfiles
        Call Module20.Mise_en_forme_Zoho(Folder & VIP)
    Next

修改sub以使用参数

Sub Mise_en_forme_Zoho(filename as string)

     ' Dims
     Dossier = "C:\Users\Raid\Desktop\RAID\Test\importation\"
     ' Fichier = Dir(Dossier & "vip*.xls")
     Set Liste = Workbooks.Open(filename)

【讨论】：

它不起作用...我有一个错误，因为 VIP 是一个字符串而不是一个对象，所以“For each”不起作用。我更改了 myfiles 中的 Workbook 和 myfiles 中的文件的 VIP，并且我有相同的错误 1004。
@thierry Dir 返回一个字符串（文件名），因此您应该将 VIP 声明为。你得到了什么错误？
编译错误。 For Each 的控制变量必须是变体或对象类型（可能不完全是因为我必须翻译它）。这就是为什么我尝试 myfiles 中的 Workbook 和 myfiles 中的 File。这修复了错误，但返回了与我原来的问题相同的错误 1004。
@thierry 对不起我的错误，将 VIP 声明为变体。
第一个文件正确完成，然后打开了第二个和第三个文件，但是模块 20 没有运行，所以到了杀死原始文件的时候会导致问题（因为模块 20 关闭最后）。

【解决方案2】：

所以，可能有一些东西是无缘无故定义的，因为我没有通过清理它，但是在给出答案之后，我去以不同的方式定义我的文档，所以不会有'不是带有循环的 Dir，它可以工作！

非常感谢！

现在是宏：

Sub Loop_pour_importation_Zoho()
'
' Loop_pour_importation_Zoho
'

'Bloquer mise-à-jour visuelle

    Application.ScreenUpdating = False
    
'Bloquer les alertes

    Application.DisplayAlerts = False
    
'Définir les variables

    Dim Folder As String
    Dim traid As String
    Dim rapport As Workbook
    Dim VIP As Variant
    
'Ouvrir le rapport traid

    Folder = "C:\Users\Raid\Desktop\RAID\Test\importation\"
    traid = Dir(Folder & "traid*.xls")
    
    Set rapport = Workbooks.Open(Folder & traid)
    
'Loop pour mettre en forme tous les fichiers Excel
    
    VIP = Dir(Folder & "vip*.xls*")
    
    Do While Len(VIP) > 0
    
        Set Clients = Workbooks.Open(Folder & VIP)
        Clients.Activate
    
        With ActiveWorkbook
            Call Module5.Mise_en_forme_Zoho
        End With
        
    VIP = Dir
        
    Loop
    
'Fermer rapport traid

    rapport.Activate
    ActiveWorkbook.Close
    
'Effacer les fichiers originaux

     Kill "C:\Users\Raid\Desktop\RAID\Test\importation\*.xls*"

'Réactiver mise-à-jour visuelle

    Application.ScreenUpdating = Vrai
    
'Réactiver les alertes

    Application.DisplayAlerts = Vrai
    
'Message de fin

    MsgBox ("La mise en forme pour l'importation vers Zoho est complétée !")

End Sub

Sub Mise_en_forme_Zoho()
'
' Mise_en_forme_Zoho Macro
'

'Nommer les variables

    Dim LastRow As Integer
    Dim Dossier As String
    Dim Fichier As String
    Dim Liste As Workbook
    Dim Document As String
    Dim wb As Workbook
    Dim RapportTraid As Workbook
    Dim DernLigne As Integer
    Dim ProchLigne As Integer
    Dim NextRow As Integer
    Dim CodeTel As Workbook
    Dim Infos As Integer
    Dim LigneFin As Integer
    Dim LigneSuite As Integer
    Dim Save As String
    Dim DateDébut As String
    Dim DateFin As String
        
'Définir le rapport à modifier
    
    Set Liste = ActiveWorkbook
    Fichier = ActiveWorkbook.Name
    Save = Left(Fichier, Len(Fichier) - 4)

'Compteur de lignes à partir de la colonne 1

    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

'Insérer et nommer les nouvelles colonnes

    Columns("A:S").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Source"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "code tel"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Phone"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Lead Status"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "start_date"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "end_date"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Offers"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Concessionnaire"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Semaine"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Event Date"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Email"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Brand/Marque"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "Model/Modèle"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "Year/Année"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "KM"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "marque"
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "model"
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "année"
    Range("S1").Select
    ActiveCell.FormulaR1C1 = "Last Name"
    Range("AH1").Select
    ActiveCell.FormulaR1C1 = "Trade-in Brand/Marque de l'échange"
    Range("AI1").Select
    ActiveCell.FormulaR1C1 = "Trade-in Model/Modèle de l'échange"
    Range("AJ1").Select
    ActiveCell.FormulaR1C1 = "Trade-in Year/Année de l'échange"

    
'Remplir les informations de base
    
    For i = 2 To LastRow
    
        Cells(i, 1).Select
        ActiveCell.FormulaR1C1 = "VP"
        Cells(i, 4).Select
        ActiveCell.FormulaR1C1 = "Imported"
        Cells(i, 11).Select
        ActiveCell.FormulaR1C1 = "=RC[22]"
        Cells(i, 16).Select
        ActiveCell.FormulaR1C1 = "=RC[18]"
        Cells(i, 17).Select
        ActiveCell.FormulaR1C1 = "=RC[18]"
        Cells(i, 18).Select
        ActiveCell.FormulaR1C1 = "=RC[18]"
        Cells(i, 19).Select
        ActiveCell.FormulaR1C1 = "=RC[6]&"" ""&RC[7]"
    
    Next i
    
'Ouvrir le rapport traid
    
    Range("U2").Select
    Selection.Copy
            
    For Each wb In Application.Workbooks
    
        If wb.Name Like "traid*" Then
            Set RapportTraid = wb
        End If
        
    Next
    
    RapportTraid.Activate
    
'Compter les lignes du rapport à partir de la ligne 1

    DernLigne = Cells(Rows.Count, 1).End(xlUp).Row
    ProchLigne = DernLigne + 1
    
'Trouver la ligne correspondant à l'événement

    Range("A" & ProchLigne).Activate
    Range("A" & ProchLigne).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    For i = 2 To DernLigne
    
        If Cells(i, 3).Value = Range("A" & ProchLigne) Then
            Range("A" & i & ":S" & i).Copy
            Liste.Activate
            NextRow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row
            Worksheets("vip").Activate
            Range("A" & NextRow & ":S" & NextRow).Activate
            Worksheets("vip").Select
            Range("A" & NextRow & ":S" & NextRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
        End If
        
    Next i

'Remplir les information du rapport Traid

    Infos = LastRow + 1
    
    For i = 2 To LastRow
    
        Cells(i, 5).Value = Cells(Infos, 8)
        Cells(i, 7).Value = Cells(Infos, 13)
    
    Next i
        
'Séparer le début et la fin de l'événement

    Columns("E:E").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        
'Remplir le numéro de la semaine

    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=ISOWEEKNUM(RC[-4])"
    
'Trouver le jour de la semaine

    Range("T" & Infos).Select
    ActiveCell.FormulaR1C1 = "=WEEKDAY(R2C[-15])"
    Range("U" & Infos).Select
    ActiveCell.FormulaR1C1 = "=WEEKDAY(R2C[-16])+1"
    Range("V" & Infos).Select
    ActiveCell.FormulaR1C1 = "=WEEKDAY(R2C[-16])"

'Changer le jour en nom

    Range("T" & Infos & ":V" & Infos).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    If Range("E" & Infos).Value = "en" Then
    
        Selection.Replace What:="1", Replacement:="Sunday", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="2", Replacement:="Monday", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="3", Replacement:="Tuesday", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="4", Replacement:="Wednesday", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="5", Replacement:="Thursday", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="6", Replacement:="Friday", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="7", Replacement:="Saturday", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
            Else:
        Selection.Replace What:="1", Replacement:="Dimanche", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="2", Replacement:="Lundi", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="3", Replacement:="Mardi", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="4", Replacement:="Mercredi", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="5", Replacement:="Jeudi", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="6", Replacement:="Vendredi", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        Selection.Replace What:="7", Replacement:="Samedi", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    
    End If

'Rentrer les jours dans Event Date

    Range("J" & Infos & ":J" & Infos).Select
    Selection.TextToColumns Destination:=Range("J" & Infos), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=Chr(10), FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        
    If Range("E" & Infos).Value = "en" Then

        Range("J3").Select
        ActiveCell.FormulaR1C1 = "=R" & Infos & "C[10]&RIGHT(R" & Infos & "C,LEN(R" & Infos & "C)-5)"
        Range("J4").Select
        ActiveCell.FormulaR1C1 = "=R" & Infos & "C[11]&RIGHT(R" & Infos & "C[1],LEN(R" & Infos & "C[1])-5)"
        Range("J5").Select
        ActiveCell.FormulaR1C1 = "=R" & Infos & "C[12]&RIGHT(R" & Infos & "C[2],LEN(R" & Infos & "C[2])-5)"
        Range("J2").Select
        Else
        Range("J3").Select
        ActiveCell.FormulaR1C1 = "=R" & Infos & "C[10]&RIGHT(R" & Infos & "C,LEN(R" & Infos & "C)-6)"
        Range("J4").Select
        ActiveCell.FormulaR1C1 = "=R" & Infos & "C[11]&RIGHT(R" & Infos & "C[1],LEN(R" & Infos & "C[1])-6)"
        Range("J5").Select
        ActiveCell.FormulaR1C1 = "=R" & Infos & "C[12]&RIGHT(R" & Infos & "C[2],LEN(R" & Infos & "C[2])-6)"
        Range("J2").Select
        
    End If
    
        ActiveCell.Value = Range("J3") & Chr(10) & Range("J4") & Chr(10) & Range("J5")

'Compléter les infos dans toutes les lignes

    For i = 3 To LastRow
        
        Cells(i, 9).Value = Cells(2, 9).Value
        Cells(i, 10).Value = Cells(2, 10).Value
    
    Next i
    
'Mise en forme générale

    Range("F1").Value = "end_date"
    
    Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
'Supprimer le numéro de campagne du rapport Traid et fermer

    RapportTraid.Activate
    Rows(ProchLigne).Select
    Selection.Delete Shift:=xlUp
    
'Copier le nom du concessionnaire

    Liste.Activate
    Range("G" & Infos).Select
    Selection.Copy
    
'Ouvrir le rapport code de téléphonie

    Set CodeTel = Workbooks.Open("C:\Users\Raid\Desktop\RAID\Test\Macro TRaid\Code Tel.xlsx")
    
    CodeTel.Activate
    
'Compter les lignes de Code Tel à partir de la ligne 1

    LigneFin = Cells(Rows.Count, 1).End(xlUp).Row
    LigneSuite = LigneFin + 1
    
'Trouver la ligne correspondant au concessionnaire

    Range("A" & LigneSuite).Activate
    Range("A" & LigneSuite).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    For i = 1 To LigneFin
    
        If Cells(i, 1).Value = Range("A" & LigneSuite) Then
            Range("B" & i).Copy
        End If
        
    Next i
    
    Liste.Activate
    Worksheets("vip").Activate
    Range("B2").Activate
    Worksheets("vip").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Fermer Code Tel

    CodeTel.Activate
    Rows(LigneSuite).Select
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Close
    
'Remplir Liste avec Code Tel et concessionnaire

    Liste.Activate
    Worksheets("vip").Activate
    
    For i = 2 To LastRow
    
        Cells(i, 2).Value = Cells(2, 2).Value
        Cells(i, 3).Formula = Cells(2, 2).Value & Cells(i, 27)
        Cells(i, 8).Formula = "VIP " & Cells(Infos, 7)
        
    Next i
    
    Columns("B:C").Select
    Columns("B:C").Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("H:H").Select
    Columns("H:H").Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
'Supprimer la ligne du rapport Traid dans Liste

    Rows(Infos).Select
    Selection.Delete Shift:=xlUp
        
'Formater les colonnes

    Columns("B:B").Select
    Selection.NumberFormat = "@"
    Columns("C:C").Select
    Selection.NumberFormat = "0"
    
'Séparer les dates en format texte et la réassembler

    Columns("E:F").Select
    Selection.NumberFormat = "@"
    Rows(Infos).Select
    Selection.NumberFormat = "General"

    Range("A" & Infos).Select
    ActiveCell.FormulaR1C1 = "=YEAR(R2C5)"
    Range("B" & Infos).Select
    ActiveCell.FormulaR1C1 = "=MONTH(R2C5)"
    Range("C" & Infos).Select
    ActiveCell.FormulaR1C1 = "=DAY(R2C5)"
    Range("D" & Infos).Select
    ActiveCell.FormulaR1C1 = _
        "=RC[-3]&""-""&IF(LEN(RC[-2])=2,RC[-2],""0""&RC[-2])&""-""&IF(LEN(RC[-1])=2,RC[-1],""0""&RC[-1])"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    DateDébut = Range("D" & Infos).Value

    Range("E" & Infos).Select
    ActiveCell.FormulaR1C1 = "=YEAR(R2C6)"
    Range("F" & Infos).Select
    ActiveCell.FormulaR1C1 = "=MONTH(R2C6)"
    Range("G" & Infos).Select
    ActiveCell.FormulaR1C1 = "=DAY(R2C6)"
    Range("H" & Infos).Select
    ActiveCell.FormulaR1C1 = _
        "=RC[-3]&""-""&IF(LEN(RC[-2])=2,RC[-2],""0""&RC[-2])&""-""&IF(LEN(RC[-1])=2,RC[-1],""0""&RC[-1])"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    DateFin = Range("H" & Infos).Value
        
    For i = 2 To LastRow
    
        Cells(i, 5).Value = DateDébut
        Cells(i, 6).Value = DateFin
        
    Next i
    
    Columns("E:F").Select
    Columns("E:F").Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.NumberFormat = "@"
    
    Rows(Infos).Select
    Selection.Delete Shift:=xlUp
    
'Sauvegarder, fermer et supprimer Liste

    ChDir "C:\Users\Raid\Desktop\RAID\Test\vers Zoho\"
    ActiveWorkbook.SaveAs Filename:= _
    Save & ".csv", FileFormat:=xlCSVUTF8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    Liste.Close
        
End Sub

【讨论】：