Microsoft 365 [RESOLU] VBA boucle, insertion plusieurs lignes, exécution formules, suppression sur si

Phil69970 à dit:

Bonjour à tous

@JVOS

Je te propose ce fichier

J'ai tout revu dans ton code

Merci de ton retour

Cliquez pour agrandir...

Gégé-45550 à dit:

Bonsoir,
à tester :

VB:

Sub export_cb2()
'
' export_cb2 Macro
'

    Dim DL, i As Long
    Dim ValeurDepart As Long
    Dim FeuilleSource As Worksheet
    Dim FeuilleCible As Worksheet
    'Dim DerniereLigne As Long
  

    ' Désactiver la mise à jour de l'écran
    Application.ScreenUpdating = True

    ' Définir les feuilles
    Set FeuilleSource = Worksheets("export_cb")  ' Feuille à trier
    Set FeuilleCible = FeuilleSource ' Feuille de destination (peut être modifiée)

    ' ---- Tri chronologique colonne A ----
    ' Déterminer la dernière ligne avec des données dans la colonne A
    DL = FeuilleSource.Cells(Rows.Count, "A").End(xlUp).Row

    ' Trier les données de la colonne A par ordre croissant
    With FeuilleSource.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & DL), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:H" & DL)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  
   ' Déterminer la dernière ligne avec des données dans la colonne A
    With FeuilleSource
'        DerniereLigne = .Cells(.Rows.Count, "A").End(xlUp).Row

        ' Copier la valeur de J1 dans B2
        .Range("B2:B" & DL).Value = .Range("J1").Value

        ' Incrémenter les valeurs dans la colonne B jusqu'à la dernière ligne
'        ValeurDepart = .Range("B2").Value
'        For i = 3 To DerniereLigne
'            .Cells(i, "B").Value = ValeurDepart
'            ValeurDepart = ValeurDepart + 1
'        Next i
    End With


    ' ---- Incrémenter et insérer des lignes ----
 
    ' Boucle pour parcourir les lignes de la feuille triée
    For i = DL To 2 Step -1
  
        ' Copier les valeurs de la ligne courante
        FeuilleSource.Rows(i).Copy
        ' Coller les valeurs dans les lignes insérées
        FeuilleSource.Rows(i + 1).Insert
        ' Effacer le contenu des cellules C1 et D1 de la ligne insérée
        FeuilleSource.Range("C" & i + 1 & ":D" & i + 1).ClearContents

        ' Effacer le contenu des cellules H1 de la ligne insérée
        FeuilleSource.Range("H" & i + 1).ClearContents
      
        ' ---- Formules et calculs ----

            ' Formule VLOOKUP dans C (ligne i+1)
            FeuilleSource.Cells(i + 1, 3).FormulaR1C1 = "=VLOOKUP(RC[2],'LIB CB'!C1:C5,2,FALSE)"

            ' Formule VLOOKUP dans D (ligne i+1)
            FeuilleSource.Cells(i + 1, 4).FormulaR1C1 = "=VLOOKUP(RC[1],'LIB CB'!C1:C5,3,FALSE)"

            ' Formule de calcul dans G (ligne i+1)
            FeuilleSource.Cells(i + 1, 7).FormulaR1C1 = "=IF(VLOOKUP(RC[-2],'LIB CB'!C1:C5,5,FALSE)=0,round(R[-1]C[1],2),ROUND(R[-1]C[1]/1.2,2))"

      
        ' Vérifier si (G i+1)<>(H i)
       If FeuilleSource.Range("G" & i + 1) <> FeuilleSource.Range("H" & i) Then
        ' Copier les valeurs de la ligne courante
            FeuilleSource.Rows(i).Copy
        ' Coller les valeurs dans les lignes insérées
            FeuilleSource.Rows(i + 2).Insert
        ' Effacer le contenu des cellules C1 et D2 des lignes insérées
            FeuilleSource.Range("C" & i + 2 & ":D" & i + 2).ClearContents
        ' Effacer le contenu des cellules H1  des lignes insérées
            FeuilleSource.Range("H" & i + 2 & ":H" & i + 2).ClearContents
          
        ' Formule VLOOKUP dans C (ligne i+2)
            FeuilleSource.Cells(i + 2, 3).FormulaR1C1 = "=VLOOKUP(RC[2],'LIB CB'!C1:C5,5,FALSE)"
        ' Formule de calcul dans H (ligne i+2)
            FeuilleSource.Cells(i + 2, 7).FormulaR1C1 = "=IF(VLOOKUP(RC[-2],'LIB CB'!C1:C5,5,FALSE)=0,0,ROUND(R[-2]C[1]/1.2*0.2,2))"
            
        End If
        
    
    Next i
  
    Application.ScreenUpdating = True

End Sub

Cordialement,

Cliquez pour agrandir...

JVOS à dit:

Quand j'ai lancé la macro, ça bug au
Ws1.Range("G" & i + 1).FormulaLocal = LaFormule

Cliquez pour agrandir...