Améliorer un macro VBA

Aujourd'hui à 11:17

Bonjour,

Mon objectif est de sélectionner dans le 1 er fichier Td-BURSA: client et Navette, crée un tableau, puis chercher les galia et son adresse des références à partir du 2em fichier Stock C-Neo.

Voici le CODE:

Sub MacroTD()

Dim wsSource As Worksheet

Dim wsDest As Worksheet

Dim derniereLigne As Long

Dim i As Long

Dim client As String

Dim navette As String

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Set wsSource = ActiveSheet

' ?? Client en premier

client = InputBox("Entrez le Client:", "Filtre Client")

If client = "" Then

MsgBox "? Client obligatoire"

Exit Sub

End If

' ?? Navette ensuite

navette = InputBox("Entrez le numéro de Navette:", "Filtre Navette")

If navette = "" Then

MsgBox "? Navette obligatoire"

Exit Sub

End If

' ?? Double filtre

If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False

wsSource.UsedRange.AutoFilter Field:=8, Criteria1:=client ' Colonne H

wsSource.UsedRange.AutoFilter Field:=9, Criteria1:=navette ' Colonne I

' ?? Nouvelle feuille

Set wsDest = Worksheets.Add

' Copier uniquement visibles

On Error Resume Next

wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A1")

If Err.Number <> 0 Then

MsgBox "?? Aucun résultat pour ce Client + Navette"

Exit Sub

End If

On Error GoTo 0

' Dernière ligne

derniereLigne = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row

' ?? Concat

For i = 2 To derniereLigne

If wsDest.Cells(i, "B").Value <> "" And wsDest.Cells(i, "D").Value <> "" Then

wsDest.Cells(i, "K").Value = _

Application.WorksheetFunction.CountIfs( _

wsDest.Range("B2:B" & i), wsDest.Cells(i, "B").Value, _

wsDest.Range("D2:D" & i), wsDest.Cells(i, "D").Value _

) & wsDest.Cells(i, "B").Value & wsDest.Cells(i, "D").Value

End If

Next i

' ?? Supprimer colonnes inutiles (ordre important)

wsDest.Columns("J").Delete

wsDest.Columns("H").Delete

wsDest.Columns("G").Delete

wsDest.Columns("A").Delete

Columns("F:F").EntireColumn.AutoFit

' ?? Recalcul dernière zone après suppression

Dim lastRow As Long, lastCol As Long

lastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row

lastCol = wsDest.Cells(1, wsDest.Columns.Count).End(xlToLeft).Column

' ??? Encadrer la liste résultats

With wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(lastRow, lastCol))

.Borders.LineStyle = xlContinuous

.Borders.Weight = xlThin

End With

' ? Mise en forme header

wsDest.Rows(1).Font.Bold = True

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

MsgBox "Terminé"

End Sub

Function WorkbookEstOuvert(nomFichier As String) As Boolean

Dim wb As Workbook

On Error Resume Next

Set wb = Workbooks(nomFichier)

WorkbookEstOuvert = Not wb Is Nothing

On Error GoTo 0

End Function

Aujourd'hui à 11:31

Bonjour

A tester

Sub MacroTD()

    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim wsStock As Worksheet
    Dim derniereLigne As Long
    Dim i As Long
    Dim client As String
    Dim navette As String
    Dim galia As String
    Dim adresse As String
    Dim stockFilePath As String
    Dim stockWb As Workbook

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set wsSource = ActiveSheet

    ' Demander le Client
    client = InputBox("Entrez le Client:", "Filtre Client")
    If client = "" Then
        MsgBox "? Client obligatoire"
        Exit Sub
    End If

    ' Demander le numéro de Navette
    navette = InputBox("Entrez le numéro de Navette:", "Filtre Navette")
    If navette = "" Then
        MsgBox "? Navette obligatoire"
        Exit Sub
    End If

    ' Filtre double
    If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
    wsSource.UsedRange.AutoFilter Field:=8, Criteria1:=client ' Colonne H
    wsSource.UsedRange.AutoFilter Field:=9, Criteria1:=navette ' Colonne I

    ' Nouvelle feuille
    Set wsDest = Worksheets.Add

    ' Copier uniquement les visibles
    On Error Resume Next
    wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A1")
    If Err.Number <> 0 Then
        MsgBox "?? Aucun résultat pour ce Client + Navette"
        Exit Sub
    End If
    On Error GoTo 0

    ' Dernière ligne
    derniereLigne = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row

    ' Concat
    For i = 2 To derniereLigne
        If wsDest.Cells(i, "B").Value <> "" And wsDest.Cells(i, "D").Value <> "" Then
            wsDest.Cells(i, "K").Value = _
            Application.WorksheetFunction.CountIfs( _
                wsDest.Range("B2:B" & i), wsDest.Cells(i, "B").Value, _
                wsDest.Range("D2:D" & i), wsDest.Cells(i, "D").Value _
            ) & wsDest.Cells(i, "B").Value & wsDest.Cells(i, "D").Value
        End If
    Next i

    ' Supprimer colonnes inutiles
    wsDest.Columns("J").Delete
    wsDest.Columns("H").Delete
    wsDest.Columns("G").Delete
    wsDest.Columns("A").Delete
    Columns("F:F").EntireColumn.AutoFit

    ' Recalcul dernière zone après suppression
    Dim lastRow As Long, lastCol As Long
    lastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row
    lastCol = wsDest.Cells(1, wsDest.Columns.Count).End(xlToLeft).Column

    ' Encadrer la liste résultats
    With wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(lastRow, lastCol))
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
    End With

    ' Mise en forme header
    wsDest.Rows(1).Font.Bold = True

    ' Ouverture du deuxième fichier
    stockFilePath = Application.GetOpenFilename("Fichiers Excel (*.xlsx), *.xlsx", , "Sélectionnez le fichier Stock C-Neo")
    If stockFilePath = "False" Then Exit Sub ' Vérifier si l'utilisateur a annulé

    Set stockWb = Workbooks.Open(stockFilePath)
    Set wsStock = stockWb.Sheets(1) ' Modifier selon l'index ou le nom de la feuille

    ' Recherche de galia et adresse
    For i = 2 To derniereLigne
        galia = wsDest.Cells(i, "B").Value ' Modifiez si nécessaire
        ' Rechercher galia dans le fichier Stock
        On Error Resume Next
        adresse = Application.WorksheetFunction.VLookup(galia, wsStock.Range("A:B"), 2, False) ' Modifier la plage si nécessaire
        On Error GoTo 0
        wsDest.Cells(i, "L").Value = adresse ' Colonne L pour l'adresse
    Next i

    ' Fermer le fichier Stock
    stockWb.Close False

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Terminé"

End Sub
Aujourd'hui à 11:47

Bonjour Joco7915
Bonjour Nadir2011

Que 9 messages, mais inscrit depuis 2022, vous devriez savoir que les codes que l'on donne ici, pour une meilleure lecture, doivent être mis entre balises

Vous avez un bouton pour ça

image

Et vous collez le code dans la fenêtre qui s'affichera

Merci d'y faire attention

Rechercher des sujets similaires à "ameliorer macro vba"