Modification de Code VBA

Mardi à 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 :)

Mardi à 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

Rechercher des sujets similaires à "modification code vba"