Insertion automatique de lignes à intervalles (VBA)

[vince_uninc]

Bonjour à tous,

C'est ma première utilisation du forum et je commence avec un problème qui est légèrement corsé selon mon niveau d'habiletés.

Dans le fichier en pièce jointe, dans l'onglet 1 on voit une liste avec des numéros de lignes, des numéros de départements et des prix. La combinaison de ces 3 informations fait qu'il n'y a pas de doublons.

Dans l'onglet 2, on voit une liste avec des numéros de lignes, des prix et une colonne indiquant le nombre de prix différents pour un même numéro de ligne.

Ce que je voudrais faire probablement à l'aide d'une macro codée en VBA, c'est d'obtenir une liste entière qui va contenir chaque combinaison unique des 3 infos de l'onglet 1 (des numéros de lignes, des numéros de départements et des prix) et pour chacune de ces combinaisons uniques ajouter les prix des numéros de lignes correspondants dans l’onglet 2.

Pour simplifier votre compréhension j’ai mis un extrait d’exemple à l’onglet 1. On peut constater que pour tous ces combinaisons uniques des 3 infos de l'onglet 1 (des numéros de lignes, des numéros de départements et des prix) il y a uniquement un seul prix 2 donc se prix 2 est ajouté dans la colonne prix 2.

Lignes Dept Prix Prix 2
3024862CL03 1 1 906,18 $ 435,00 $
3024862CL03 17 2 367,35 $ 435,00 $
3024862CL11-8 1 1 906,18 $ 435,00 $
3024862CL12-7 1 1 770,95 $ 4 222,00 $
3024862CL12-7 41 2 619,18 $ 4 222,00 $

Toutefois, comme on peut le constater dans le tableau suivant j’ai seulement 2 combinaisons uniques des 3 infos de l'onglet 1 (des numéros de lignes, des numéros de départements et des prix), mais j’ai 4 Prix 2 différents. Je voudrais donc que pour chacune des 2 combinaisons uniques initiales, il y ait introduction de ligne afin d’indiquer pour chaque combinaison unique les 4 Prix 2 différents.

Lignes Dept Prix Prix 2
3029051CL0621 1 3 944,63 $ 26 021,00 $
3029051CL0621 1 3 944,63 $ 100,00 $
3029051CL0621 1 3 944,63 $ 912,00 $
3029051CL0621 1 3 944,63 $ 6 755,00 $
3029051CL0621 41 4 840,74 $ 26 021,00 $
3029051CL0621 41 4 840,74 $ 100,00 $
3029051CL0621 41 4 840,74 $ 912,00 $
3029051CL0621 41 4 840,74 $ 6 755,00 $

Ici j’ai seulement utilisé un extrait des données pour l’exemple mais je voudrais ultimement que cette logique soit appliquée à l’ensemble des données. Si vous avez des indices ou savez comment faire je suis ouverts à vos propositions.

Merci d’avance d’avoir pris le temps de tenter de m’aider c’est grandement apprécié!

 

[Grand Chaman Excel]

Re : Insertion automatique de lignes à intervalles (VBA)

Bonjour et bienvenue sur le forum,
Voici une macro qui fait le travail... quoique un peu longue à exécuter étant donné le nombre de lignes différentes.
(Pas le temps d'optimiser ce soir...)

Sub toto()
   Dim wsTemp As Worksheet
   Dim ar, arF
   Dim i As Long, j As Long, k As Long
   Dim rg2 As Range

   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

   'Créer une feuille temporaire
   On Error Resume Next
   Sheets("Temp").Delete
   Set wsTemp = Sheets.Add
   wsTemp.Name = "Temp"

   ar = Sheets("1").Cells(1).CurrentRegion.Value
   ReDim arF(1 To 4, 1 To 1)
   Set rg2 = Sheets("2").Cells(1).CurrentRegion
   For i = 2 To UBound(ar, 1)
      Application.StatusBar = i & "/" & UBound(ar, 1)
      rg2.AutoFilter field:=1, Criteria1:=ar(i, 1)    'filtre
      rg2.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsTemp.Cells(1) 'copie des lignes visibles

      j = wsTemp.Cells(1).CurrentRegion.Rows.Count
      'Tableau de résultat
      For k = 1 To j
         ReDim Preserve arF(1 To 4, 1 To UBound(arF, 2) + 1)
         arF(1, UBound(arF, 2)) = ar(i, 1)   'ligne
         arF(2, UBound(arF, 2)) = ar(i, 2)   'Dept
         arF(3, UBound(arF, 2)) = ar(i, 3)   'prix
         arF(4, UBound(arF, 2)) = wsTemp.Cells(k, 2) 'Prix 2
      Next k
      wsTemp.UsedRange.Clear
   Next i
   
   'Résultat
   Sheets("1").Range("L1").Resize(UBound(arF, 2), UBound(arF, 1)) = Application.Transpose(arF)
   
   Sheets("Temp").Delete
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
   Application.StatusBar = False

End Sub

A+

 

[mapomme]

Re : Insertion automatique de lignes à intervalles (VBA)

Bonjour vince_uninc et bienvenu sur XLD , Grand Chaman Excel

Un autre essai basé sur des dictionnaires.

Pour utiliser les dictionnaires, il faut sous l'environnement VBA, vérifier que la référence à "Microsoft Scripting Runtime" est activée":

Pour cela:

• passer sous environnement VBA en tapant la combinaison de touches Alt + F11 (touche de fonction F11)
• dans le menu "Outils", cliquer sur "Références..."
• dans la fenêtre qui s'ouvre, rechercher dans la liste des références disponibles l'item "Microsoft Scripting Runtime"
  • si l'item est déjà coché alors c'est tout bon, refermer la fenêtre
  • si l'item n'est pas coché, alors le cocher puis refermer la fenêtre
  • (suivant les cas, l'item est situé soit vers le haut de liste, sinon le rechercher par ordre alphabétique)

Comme cela n'était pas précisé, si pour un élément de la liste1, il n'y a aucune correspondance dans la liste2, alors l'élément de la liste1 est inséré dans la liste résultat mais avec une cellule vide en 4eme colonne (Prix 2)

Le temps de traitement est d'environ 1,6s.

NB: les tableaux (liste1 et liste2 des feuilles "1" et "2") n'ont pas besoin d'être triés.

Le code VBA dans Module1:

Sub test()

Dim Tab1 As Variant, Tab2 As Variant, Res() As Variant
Dim xrg As Range, Base As Range
Dim i As Long, j As Long, k As Long, n As Long, T0 As Single
Dim dico1 As New Scripting.Dictionary, n1 As Long, S1 As Variant, K1 As Long
Dim dico2 As New Scripting.Dictionary, n2 As Long, S2 As Variant, K2 As Long

T0 = Timer
Application.ScreenUpdating = False
'lecture tableau 1
With Sheets("1")
  Set Base = .Range("E2")
  Range("e:h").Clear
  Tab1 = .Range("A2:C" & .Cells(.Rows.Count, "a").End(xlUp).Row).Value
End With
K1 = UBound(Tab1)
For i = 1 To K1
    dico1(Tab1(i, 1)) = dico1(Tab1(i, 1)) & "\" & i
Next i

'lecture tableau 2
With Sheets("2")
  Tab2 = .Range("A2:C" & .Cells(.Rows.Count, "a").End(xlUp).Row).Resize(, 2).Value
End With
K2 = UBound(Tab2)
For i = 1 To K2
    dico2(Tab2(i, 1)) = dico2(Tab2(i, 1)) & "\" & i
Next i

'boucle sur dico1
For i = 0 To dico1.Count - 1
  S1 = Split(Mid(dico1.Items(i), 2), "\")
  If dico2.Exists(dico1.Keys(i)) Then
    S2 = Split(Mid(dico2(dico1.Keys(i)), 2), "\")
    K1 = UBound(S1): K2 = UBound(S2)
    ReDim Res(1 To (K1 + 1) * (K2 + 1), 1 To 4)
    n = 0
    For j = 0 To K1
      For k = 0 To K2
        n = n + 1
        Res(n, 1) = Tab1(S1(j), 1)
        Res(n, 2) = Tab1(S1(j), 2)
        Res(n, 3) = Tab1(S1(j), 3)
        Res(n, 4) = Tab2(S2(k), 2)
      Next k
    Next j
    Base.Resize(UBound(Res), 4) = Res
    Set Base = Base.Offset(UBound(Res))
  Else
    K1 = UBound(S1)
    ReDim Res(1 To (K1 + 1), 1 To 4)
    n = 0
    For j = 0 To K1
      n = n + 1
      Res(n, 1) = Tab1(S1(j), 1)
      Res(n, 2) = Tab1(S1(j), 2)
      Res(n, 3) = Tab1(S1(j), 3)
      Res(n, 4) = ""
    Next j
    Base.Resize(UBound(Res), 4) = Res
    Set Base = Base.Offset(UBound(Res))
  End If
Next i

With Sheets("1")
  'Format
  .Range("c2").Copy
  .Range("g2:h" & .Range("g" & .Rows.Count).End(xlUp).Row).PasteSpecial _
        Paste:=xlPasteFormats
  'titre
  .Range("e1:g1") = .Range("a1:c1").Value
  .Range("h1") = "Prix 2"
  'encadrement
  .Range("e1:h" & .Range("g" & .Rows.Count).End(xlUp).Row).Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = False
MsgBox Format(Timer - T0, "0.00""s""")
End Sub

voir fichier dans le message #5

 

[mapomme]

Re : Insertion automatique de lignes à intervalles (VBA)

(re)Bonjour à tous,

ERRATA: une erreur de copier/coller non modifié s'est glissée dans la version v2 pour le cas où il n'y a pas de correspondance dans le tableau2 pour un item du tableau1. La version v3 corrige l'erreur. Le code affiché dans le msg précédent a été rectifié.

voir fichier dans le message #5

 

[mapomme]

Re : Insertion automatique de lignes à intervalles (VBA)

(re)

C'était plus grave que je pensais (erreur de logique!) pour les cas de non-concordance.
Voilà une dernière version qui devrait être juste pour ces cas.

 

[vince_uninc]

Re : Insertion automatique de lignes à intervalles (VBA)

Wow!

Merci beaucoup Grand Chaman Excel et mapomme j'apprécie grandement le temps que vous avez passé à résoudre mon problème. J'essaye tranquillement mais sûrement d'apprendre par moi-même le codage VBA pour Excel et des coups de mains comme les votres sont grandement apprécier et m'aide à aller dans la bonne direction pour devenir autonome.

Encore Merci