Modification de Code VBA

Le 07/07/2026 à 11:38

Bonjour,

J'ai un problème avec mon code VBA depuis la modification du nom du fichier a allez récupérer.

Je vous joins ci-dessous les intitulés de mes anciens fichiers et de nouveaux avec le code de la macro.

Anciens fichiers Excel :

Nom du fichier : ARTICLE_A_L_OFFICE_6161

Nom du fichier : ARTICLE_A_L_OFFICE_6161 - HORS CHAINE UNIQ

Nom du fichier : ARTICLE_A_L_OFFICE_6161 - UNIQUEMENT CHAIN

Nouveaux fichiers Excel :

Nom du fichier : ARTICLE_A_L_OFFICE_100726_6281

Nom du fichier : ARTICLE_A_L_OFFICE_100726_6281-CHAINE

Nom du fichier : ARTICLE_A_L_OFFICE_100726_6281-HORS_CHAINE

Sub officeDourdanB()

    Dim UsN As String
    Dim sPath As String, sFic As String
    Dim NOff As Integer

    Range("Num_Office").Select
    NOff = Selection.Value

    'fichier implatation article a office+configurationCSV
    Sheets("Y coller article à l'office").Select
    Range("A2").Select

    'Recherche Fichier d'implantation dans USER Article a l'office
    UsN = UCase(Environ("username"))
    Select Case UsN
    Case "PEREIRA" 'Baptiste
      sPath = "\\qdddas\dddas\users\PEREIRA\Implantation\"
    Case "TASSOT" 'Nicolas
      sPath = "\\qdddas\dddas\users\TASSOT\Implantation\"
    Case "PABON" 'Sylvain
      sPath = "\\qdddas\dddas\users\PABON\Implantation\"
    Case "AURELIE" 'Aurelie
     sPath = "F:\abeziat\Implantation\"
    Case "GAUTHIER" 'Melanie
      sPath = "\\qdddas\dddas\users\GAUTHIER\Implantation\"
    Case "NOLLET" 'Willy
      sPath = "\\qdddas\dddas\users\NOLLET\Implantation\"
    End Select
    ' Trouver le nom du csv
    sFic = Dir(sPath & "ARTICLE_A_L_OFFICE_" & NOff & ".csv")
    If sFic = "" Then
    MsgBox "Problème pour trouver le fichier CSV", vbCritical, "OUPS"
    Exit Sub
    End If
    ' Si fichier trouvé
    Workbooks.OpenText (sPath & sFic), Origin:=xlWindows, StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True

    'Operation d'implation d'office avec suppresion d'espace + copier/coller dans le fichier Appro site extereieur Office dans l'onglet " YcollerBO"
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=TRIM(RC[-1])"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C20000")
    Range("C2:C20000").Select
    ActiveWindow.SmallScroll Down:=-24
    Selection.Copy
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=-249
    Range("B2:D2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("Outils Appro office site extérieur Dourdan.xlsx").Activate
    ActiveSheet.Paste
    Range("D2").Select

    'Recherche Fichier d'implantation dans USER Article a l'office hors chaine

    UsN = UCase(Environ("username"))
    Select Case UsN
    Case "PEREIRA"
      sPath = "\\qdddas\dddas\users\PEREIRA\Implantation\"
    Case "TASSOT"
      sPath = "\\qdddas\dddas\users\TASSOT\Implantation\"
    Case "PABON"
      sPath = "\\qdddas\dddas\users\PABON\Implantation\"
    Case "AURELIE" 'Aurelie
     sPath = "F:\abeziat\Implantation\"
    Case "GAUTHIER" 'Melanie
      sPath = "\\qdddas\dddas\users\GAUTHIER\Implantation\"
    Case "NOLLET" 'Willy
      sPath = "\\qdddas\dddas\users\NOLLET\Implantation\"
    End Select
    ' Trouver le nom du csv
    sFic = Dir(sPath & "ARTICLE_A_L_OFFICE_" & NOff & "*.csv")
    If sFic = "" Then
    MsgBox "Problème pour trouver le fichier CSV", vbCritical, "OUPS"
    Exit Sub
    End If
    ' Si fichier trouvé
    'fichier implatation article a office hors chaine + configurationCSV
    Workbooks.OpenText (sPath & sFic), Origin:=xlWindows, StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=TRIM(RC[-1])"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C199")
    Range("C2:C199").Select
    Selection.Copy
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Windows("Outils Appro office site extérieur Dourdan.xlsx").Activate

    Dim wbCSV As Workbook
    Dim wsCSV As Worksheet
    Dim fileName As String

    ' Définir le préfixe du nom de fichier
    Dim filePrefix As String
    filePrefix = "ARTICLE_A_L_OFFICE_"

    ' Rechercher le fichier CSV basé sur le préfixe et un motif de recherche
    fileName = Dir(sPath & filePrefix & "*HORS*CHAINE*.csv")

    ' Vérifier si un fichier correspondant a été trouvé
    If fileName = "" Then
    MsgBox "Aucun fichier CSV correspondant au préfixe '" & filePrefix & "' n'a été trouvé.", vbCritical, "Erreur"
    Exit Sub
    End If

    ' Vérifier si le fichier est déjà ouvert
    Dim found As Boolean
    found = False
    For Each wb In Workbooks
    If wb.Name = fileName Then
    ' Le fichier est déjà ouvert, référencez-le et sortez de la boucle
    Set wbCSV = wb
    found = True
    Exit For
    End If
    Next wb

    ' Si le fichier n'est pas déjà ouvert, l'ouvrir
    If Not found Then
    Set wbCSV = Workbooks.Open(sPath & fileName)
    End If

    Set wsCSV = wbCSV.Sheets(1)

    ' Utiliser la formule VLOOKUP
    'Range("D2").FormulaR1C1 = _
    '"=IFERROR(VLOOKUP(RC[-3], '" & wbCSV.Name & "'!C2:C4, 3, FALSE), 0)"

    'Selection.AutoFill Destination:=Range("D2:D300")
    'Range("D2:D300").Select
    'Range("D2").Select
   ' Range(Selection, Selection.End(xlDown)).Select
    'Selection.Copy
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     '   :=False, Transpose:=False
    ' Utiliser la formule VLOOKUP
    Range("D2").FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-3], '" & wbCSV.Name & "'!C2:C4, 3, FALSE), 0)"

    ' Remplacer la plage D2:D300 par D2 jusqu'à la dernière ligne remplie
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row ' Trouver la dernière ligne remplie en fonction de la colonne C

    ' Remplir chaque cellule individuellement dans la plage D2:Dxxx
    Dim i As Long
    For i = 2 To lastRow ' Commencer à partir de la ligne 2, car D1 est déjà rempli
        Range("D" & i).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-3], '" & wbCSV.Name & "'!C2:C4, 3, FALSE), 0)"
    Next i

    ' Copier et coller en tant que valeurs
    Range("D2:D" & lastRow).Copy
    Range("D2:D" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    ' Fermer le classeur CSV
    wbCSV.Close SaveChanges:=False

End Sub

Merci à vous de votre aide :)

Le 07/07/2026 à 12:41

Bonjour Augusto,

1) pour le sPath, je ne comprends pourquoi tu répètes autant de lignes, alors qu'il suffit de 2

    'Recherche Fichier d'implantation dans USER Article a l'office
    UsN = UCase(Environ("username"))
    Select Case UsN
      Case "AURELIE" 'Aurelie
       sPath = "F:\abeziat\Implantation\"
      Case Else
        sPath = "\\qdddas\dddas\users\" & UsN & "\Implantation\"""
    End Select

2) Pourquoi répéter 2 fois la construction du sPath, totalement inutile pour moi

2) Pour trouver le fichier CHAINE, il suffit de mettre un joker

 sFic = Dir(sPath & "ARTICLE_A_L_OFFICE*" & NOff & "*-CHAINE.csv")

3) Pour trouver le fichier HORS_CHAINE

sFic = Dir(sPath & "ARTICLE_A_L_OFFICE_" & NOff & "*-HORS*.csv")

Voilà ce que j'ai pu voir

Hier à 15:31

Bonjour,

Merci des infos, je viens d'essayer les deux codes dont vous m'avez communiquer , j'ai un souci avec celui-ci

sFic = Dir(sPath & "ARTICLE_A_L_OFFICE_" & NOff & "*-HORS*.csv")

Il me dit qu'il ne retrouve pas le fichier CSV.

J'ai essayé avec celui-ci ci-dessous pour voir mais même problème.

sFic = Dir(sPath & "ARTICLE_A_L_OFFICE*" & NOff & "*-CHAINE.csv")

Merci de ton aide.

Baptiste.

Hier à 15:45

Bonjour

Code à tester

Option Explicit

Sub officeDourdanB()

    Dim UsN As String
    Dim sPath As String, sFic As String
    Dim NOff As Integer
    Dim wbCSV As Workbook
    Dim wsCSV As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim filePrefix As String
    Dim fileName As String

    ' Récupération du numéro d'office
    NOff = Range("Num_Office").Value

    ' Définition du chemin en fonction de l'utilisateur
    UsN = UCase(Environ("username"))
    Select Case UsN
        Case "PEREIRA"
            sPath = "\\qdddas\dddas\users\PEREIRA\Implantation\"
        Case "TASSOT"
            sPath = "\\qdddas\dddas\users\TASSOT\Implantation\"
        Case "PABON"
            sPath = "\\qdddas\dddas\users\PABON\Implantation\"
        Case "AURELIE"
            sPath = "F:\abeziat\Implantation\"
        Case "GAUTHIER"
            sPath = "\\qdddas\dddas\users\GAUTHIER\Implantation\"
        Case "NOLLET"
            sPath = "\\qdddas\dddas\users\NOLLET\Implantation\"
        Case Else
            MsgBox "Utilisateur non reconnu.", vbCritical, "Erreur"
            Exit Sub
    End Select

    ' Trouver le nom du csv
    sFic = Dir(sPath & "ARTICLE_A_L_OFFICE_" & NOff & ".csv")
    If sFic = "" Then
        MsgBox "Problème pour trouver le fichier CSV", vbCritical, "OUPS"
        Exit Sub
    End If

    ' Ouvrir le fichier CSV
    Set wbCSV = Workbooks.OpenText(sPath & sFic, Origin:=xlWindows, StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True)
    Set wsCSV = wbCSV.Sheets(1)

    ' Opérations d'implantation
    With wsCSV
        .Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("C2").FormulaR1C1 = "=TRIM(RC[-1])"
        .Range("C2:C20000").FillDown

        .Range("C2:C20000").Copy
        .Range("B2").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        .Columns("C:C").Delete Shift:=xlToLeft
    End With

    ' Copier les données dans le fichier cible
    Windows("Outils Appro office site extérieur Dourdan.xlsx").Activate
    wsCSV.Range("B2:D" & wsCSV.Cells(wsCSV.Rows.Count, "B").End(xlUp).Row).Copy
    ActiveSheet.Paste

    ' Traitement du fichier "Hors Chaîne"
    filePrefix = "ARTICLE_A_L_OFFICE_"
    fileName = Dir(sPath & filePrefix & "*HORS*CHAINE*.csv")

    If fileName = "" Then
        MsgBox "Aucun fichier CSV correspondant au préfixe '" & filePrefix & "' n'a été trouvé.", vbCritical, "Erreur"
        Exit Sub
    End If

    ' Ouvrir le fichier CSV hors chaîne
    Set wbCSV = Workbooks.Open(sPath & fileName)
    Set wsCSV = wbCSV.Sheets(1)

    ' Utilisation de VLOOKUP
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 2 To lastRow
        Range("D" & i).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-3], '" & wbCSV.Name & "'!C2:C4, 3, FALSE), 0)"
    Next i

    ' Copier et coller en tant que valeurs
    Range("D2:D" & lastRow).Copy
    Range("D2:D" & lastRow).PasteSpecial Paste:=xlPasteValues

    ' Fermer le classeur CSV
    wbCSV.Close SaveChanges:=False

End Sub
Hier à 16:07

Bonjour Joco,

je viens d'essayer ton code à l'instant. J'ai une fonction ou une variable qui se met en erreur sur la ligne ci-dessous

"OpenText" surligner en jaune.

' Ouvrir le fichier CSV
    Set wbCSV = Workbooks.OpenText(sPath & sFic, Origin:=xlWindows, StartRow:=1, Local:=True, DataType:=xlDelimited, Semicolon:=True)
    Set wsCSV = wbCSV.Sheets(1)

Baptiste.

Hier à 17:40

a tester

Sub officeDourdanB()

    Dim UsN As String
    Dim sPath As String, sFic As String
    Dim NOff As Integer
    Dim wbCSV As Workbook
    Dim wsCSV As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim filePrefix As String
    Dim fileName As String

    ' Récupération du numéro d'office
    NOff = Range("Num_Office").Value

    ' Définition du chemin en fonction de l'utilisateur
    UsN = UCase(Environ("username"))
    Select Case UsN
        Case "PEREIRA"
            sPath = "\\qdddas\dddas\users\PEREIRA\Implantation\"
        Case "TASSOT"
            sPath = "\\qdddas\dddas\users\TASSOT\Implantation\"
        Case "PABON"
            sPath = "\\qdddas\dddas\users\PABON\Implantation\"
        Case "AURELIE"
            sPath = "F:\abeziat\Implantation\"
        Case "GAUTHIER"
            sPath = "\\qdddas\dddas\users\GAUTHIER\Implantation\"
        Case "NOLLET"
            sPath = "\\qdddas\dddas\users\NOLLET\Implantation\"
        Case Else
            MsgBox "Utilisateur non reconnu.", vbCritical, "Erreur"
            Exit Sub
    End Select

    ' Trouver le nom du csv
    sFic = Dir(sPath & "ARTICLE_A_L_OFFICE_" & NOff & ".csv")
    If sFic = "" Then
        MsgBox "Problème pour trouver le fichier CSV", vbCritical, "OUPS"
        Exit Sub
    End If

    ' Ouvrir le fichier CSV
    On Error Resume Next
    Set wbCSV = Workbooks.OpenText(Filename:=sPath & sFic, Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, Semicolon:=True)

    ' Vérifier si le fichier a été ouvert avec succès
    If wbCSV Is Nothing Then
        MsgBox "Erreur lors de l'ouverture du fichier CSV.", vbCritical, "Erreur"
        Exit Sub
    End If
    On Error GoTo 0

    Set wsCSV = wbCSV.Sheets(1)

    ' Opérations d'implantation
    With wsCSV
        .Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("C2").FormulaR1C1 = "=TRIM(RC[-1])"
        .Range("C2:C20000").FillDown

        .Range("C2:C20000").Copy
        .Range("B2").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        .Columns("C:C").Delete Shift:=xlToLeft
    End With

    ' Copier les données dans le fichier cible
    Windows("Outils Appro office site extérieur Dourdan.xlsx").Activate
    wsCSV.Range("B2:D" & wsCSV.Cells(wsCSV.Rows.Count, "B").End(xlUp).Row).Copy
    ActiveSheet.Paste

    ' Traitement du fichier "Hors Chaîne"
    filePrefix = "ARTICLE_A_L_OFFICE_"
    fileName = Dir(sPath & filePrefix & "*HORS*CHAINE*.csv")

    If fileName = "" Then
        MsgBox "Aucun fichier CSV correspondant au préfixe '" & filePrefix & "' n'a été trouvé.", vbCritical, "Erreur"
        Exit Sub
    End If

    ' Ouvrir le fichier CSV hors chaîne
    Set wbCSV = Workbooks.Open(sPath & fileName)
    Set wsCSV = wbCSV.Sheets(1)

    ' Utilisation de VLOOKUP
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 2 To lastRow
        Range("D" & i).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-3], '" & wbCSV.Name & "'!C2:C4, 3, FALSE), 0)"
    Next i

    ' Copier et coller en tant que valeurs
    Range("D2:D" & lastRow).Copy
    Range("D2:D" & lastRow).PasteSpecial Paste:=xlPasteValues

    ' Fermer le classeur CSV
    wbCSV.Close SaveChanges:=False

End Sub
Rechercher des sujets similaires à "modification code vba"