Alignement des lignes par macro

Le 18/03/2022 à 11:09

Bonjour à tous,

Manuellement simple, j'y arrive pas par macro.

J'ai 3 listes d'élèves par classe dans ma page rappro, et vu que la 1ere est la plus longue, je vais aligner les 2 autres sur la ligne des changements de classe de la 1ere.

Comme Il y aura plusieurs classes pour chaque liste, je dois bien faire 3 boucles imbriquées.

mais çà tourne sans fin.

Merci

8rappros.xlsm (110.75 Ko)
Le 18/03/2022 à 12:18

Bonjour

J'aurais plutôt fait ceci dans la première partie du code

Sub rappro2()
Dim ws6 As Worksheet, ws7 As Worksheet
Dim i As Integer, k As Integer, ligne As Integer, m as integer
Dim deb1 As Integer, fin1 As Integer, drnNvLst As Integer, drnList As Integer

Set ws6 = Sheets("ptage")
Set ws7 = Sheets("rappro")
'accélération macro
Application.ScreenUpdating = False

'suppression base précédente
ws7.Columns("A:T").ClearContents

'données des pointages faux
drnNvLst = ws6.Range("Y" & Rows.Count).End(xlUp).Row
drnList = ws6.Range("Q" & Rows.Count).End(xlUp).Row

'alimentation feuille "rappro" avec les classes de la 1ere liste
k = 2
For i = 2 To drnNvLst
     If ws6.Range("AE" & i) <> "" And ws6.Range("AE" & i) - ws6.Range("AF" & i) <> ws6.Range("AG" & i) Then
        'on cherche les lignes des 2 listes rapprochées dans le résumé
        On Error Resume Next
        ligne = ws6.Range("Q:Q").Find(ws6.Range("AD" & i), LookIn:=xlValues, lookat:=xlWhole).Row
        If ligne > 0 Then
            debl = ws6.Range("O" & ligne)
            fin1 = ws6.Range("P" & ligne)
        End If
        'On Error GoTo 0
        For m = debl To fin1
            ws7.Range("A" & k) = ws6.Range("A" & m)
            ws7.Range("B" & k) = ws6.Range("B" & m)
            ws7.Range("C" & k) = ws6.Range("C" & m)
            ws7.Range("D" & k) = ws6.Range("D" & m)
            ws7.Range("E" & k) = ws6.Range("E" & m)
            ws7.Range("F" & k) = ws6.Range("F" & m)
            k = k + 1
        Next m
    End If
Next i
'alimentation feuille "rappro" avec les classes de la 2eme liste

A voir si cela fonctionne pour vous avant d'aller plus loin pour les listes 2 et 3

Je ne comprends votre séquence "alignement des classes". Que cherchez-vous à faire ?
Pour déjà définissez-vous la variable drnclas1 dans la feuille ptage ?

Le 18/03/2022 à 12:53

Bonjour fronck, Dan , le forum,

Un essai ....de ce que j'ai compris......

Sub test()
 Dim Fsource As Worksheet, Fdest As Worksheet
 Dim derlig&, k&, kk&, kkk&, i&, ii&, col&, j&
 Dim liste, tb1(), tb2(), tb3()
 Dim clas$

 Application.ScreenUpdating = False

  Set Fsource = Sheets("ptage")
    Set Fdest = Sheets("rappro")
       derlig = Fsource.UsedRange.Rows.Count + 1
       liste = Fsource.Range("A2:AH" & derlig)

     k = 0: kk = 0: kkk = 0
     For i = 1 To UBound(liste, 1)
      If liste(i, 31) <> "" And liste(i, 31) - liste(i, 32) <> liste(i, 33) Then
       clas = liste(i, 30)

       For j = 1 To UBound(liste, 1)
        If liste(j, 17) = clas Then
         deb1 = liste(j, 15): fin1 = liste(j, 16)
          For ii = deb1 - 1 To fin1 - 1
             ReDim Preserve tb1(1 To 6, 1 To k + 1)
              For col = 1 To 6
               tb1(col, 1 + k) = liste(ii, col)
              Next col
              k = k + 1
          Next ii

         deb2 = liste(j, 18): fin2 = liste(j, 19)
          For ii = deb2 - 1 To fin2 - 1
             ReDim Preserve tb2(1 To 6, 1 To kk + 1)
              For col = 1 To 6
               tb2(col, 1 + kk) = liste(ii, col + 7)
              Next col
              kk = kk + 1
          Next ii

         deb3 = liste(j, 21): fin3 = liste(j, 22)
          For ii = deb3 - 1 To fin3 - 1
             ReDim Preserve tb3(1 To 6, 1 To kkk + 1)
              For col = 1 To 6
               tb3(col, 1 + kkk) = liste(ii, col + 23)
              Next col
              kkk = kkk + 1
          Next ii
        End If
       Next j
      End If
     Next i

      On Error Resume Next
       With Fdest
        .Cells.Delete
        .Range("A1").Resize(UBound(tb1, 2), 6) = Application.Transpose(tb1)
        .Range("H1").Resize(UBound(tb2, 2), 6) = Application.Transpose(tb2)
        .Range("O1").Resize(UBound(tb3, 2), 6) = Application.Transpose(tb3)
        .Columns.AutoFit
        .Activate
       End With
End Sub

CTRL + e pour exécuter la macro test...

4fronck.xlsm (122.54 Ko)

Cordialement,

Le 18/03/2022 à 16:23

Bonjour dan et xorsankukai,

Merci pour vos réponses.

Désolé pour m'être fait mal comprendre, mais c'est un alignement par classe (C2 C5 C8 4G1) que je veux, comme çà :

3

J' avais

Insert Shift:=xlDown

dans mon code qui devait faire l'opération.

ws7.Range("O" & clas3 & ":T" & clas1).Select
Selection.Insert Shift:=xlDown

Entre temps j'ai compris qu'en décalant une fois, le trou crée faisait beuger la macro, et je vais essayer un recalcul à chaque opération avec :

ws6.Range("I" & Rows.Count).End(xlUp).Row
ws6.Range("P" & Rows.Count).End(xlUp).Row

Merci, à bientôt.

Le 18/03/2022 à 16:56

Votre code complet à tester

Sub rappro()
Dim ws6 As Worksheet, ws7 As Worksheet
Dim i As Integer, k As Integer, ligne As Integer, m As Integer
Dim deb As Integer, fin As Integer, drnNvLst As Integer, drnList As Integer, drnclas As Integer

Set ws6 = Sheets("ptage")
Set ws7 = Sheets("rappro")
'accélération macro
Application.ScreenUpdating = False

'suppression base précédente
ws7.Columns("A:T").ClearContents

'données des pointages faux
drnNvLst = ws6.Range("Y" & Rows.Count).End(xlUp).Row
drnList = ws6.Range("Q" & Rows.Count).End(xlUp).Row

'alimentation feuille "rappro" avec les classes de la 1ere liste
k = 2
For i = 2 To drnNvLst
     If ws6.Range("AE" & i) <> "" And ws6.Range("AE" & i) - ws6.Range("AF" & i) <> ws6.Range("AG" & i) Then
        'on cherche les lignes des 2 listes rapprochées dans le résumé
        On Error Resume Next
        ligne = ws6.Range("Q:Q").Find(ws6.Range("AD" & i), LookIn:=xlValues, lookat:=xlWhole).Row
        If ligne > 0 Then
            deb = ws6.Range("O" & ligne)
            fin = ws6.Range("P" & ligne)
        End If
        'On Error GoTo 0
        For m = deb To fin
            ws7.Range("A" & k) = ws6.Range("A" & m)
            ws7.Range("B" & k) = ws6.Range("B" & m)
            ws7.Range("C" & k) = ws6.Range("C" & m)
            ws7.Range("D" & k) = ws6.Range("D" & m)
            ws7.Range("E" & k) = ws6.Range("E" & m)
            ws7.Range("F" & k) = ws6.Range("F" & m)
            k = k + 1
        Next m
    End If
Next i

'alimentation feuille "rappro" avec les classes de la 2eme liste
deb = 0
fin = 0
k = 2
For i = 2 To drnNvLst
    If ws6.Range("AE" & i) <> "" And ws6.Range("AE" & i) - ws6.Range("AF" & i) <> ws6.Range("AG" & i) Then
        On Error Resume Next
        ligne = ws6.Range("Q:Q").Find(ws6.Range("AD" & i), LookIn:=xlValues, lookat:=xlWhole).Row
        If ligne > 0 Then
            deb = ws6.Range("R" & ligne) - 1
            fin = ws6.Range("S" & ligne)
        End If
        'On Error GoTo 0
        For m = deb + 1 To fin
            ws7.Range("H" & k) = ws6.Range("H" & m)
            ws7.Range("I" & k) = ws6.Range("I" & m)
            ws7.Range("J" & k) = ws6.Range("J" & m)
            ws7.Range("K" & k) = ws6.Range("K" & m)
            ws7.Range("L" & k) = ws6.Range("L" & m)
            ws7.Range("M" & k) = ws6.Range("M" & m)
        k = k + 1
        Next m
    End If
Next i

'alimentation feuille "rappro" avec les classes de la 3eme liste
deb = 0
fin = 0
k = 2
For i = 2 To drnNvLst
    If ws6.Range("AE" & i) <> "" And ws6.Range("AE" & i) - ws6.Range("AF" & i) <> ws6.Range("AG" & i) Then
        On Error Resume Next
        ligne = ws6.Range("Q:Q").Find(ws6.Range("AD" & i), LookIn:=xlValues, lookat:=xlWhole).Row
        If ligne > 0 Then
            deb = ws6.Range("U" & ligne)
            fin = ws6.Range("V" & ligne)
        End If
        'On Error GoTo 0

        For m = deb To fin
            ws7.Range("O" & k) = ws6.Range("X" & m)
            ws7.Range("P" & k) = ws6.Range("Y" & m)
            ws7.Range("Q" & k) = ws6.Range("Z" & m)
            ws7.Range("R" & k) = ws6.Range("AA" & m)
            ws7.Range("S" & k) = ws6.Range("AB" & m)
            ws7.Range("T" & k) = ws6.Range("AC" & m)
            k = k + 1
        Next m
    End If
Next i

'alignement des classes
With ws7
    drnclas = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 2 To drnclas
        If .Range("H" & i) <> .Range("A" & i) Then .Range("H" & i & ":N" & i).Insert Shift:=xlDown
        If .Range("O" & i) <> .Range("A" & i) Then .Range("O" & i & ":T" & i).Insert Shift:=xlDown
    Next i
End With
Application.ScreenUpdating = True
End Sub

si ok-->

Cordialement

Le 18/03/2022 à 17:33

Ok super Dan bravo

je vais pouvoir m'attaquer au rapprochement des noms.

Cdt

Le 18/03/2022 à 18:16

Bonsoir,

Bravo Dan, je ne suis pas parvenu à créer le décalage avec les "tablo".....

Je me garde donc ta méthode avec

.Insert Shift:=xlDown

Merci pour la combine,

0fronck.xlsm (119.95 Ko)

Bonne soirée à vous 2,

A bientôt,

Rechercher des sujets similaires à "alignement lignes macro"