Microsoft 365 Déplacer un groupe de cellules

[Usine à gaz]

Bonjour à toutes et à tous,
Je vous souhaite un beau WE (pas trop chaud)

Comme l'indique le titre du fil, je n'arrive pas à réaliser mon besoin : Déplacer un groupe de cellules

1 - déplacer les cellules Col B qui contiennent un n° de téléphone en colonne A au niveau des cellules col B qui contiennent le mot date,
2 - supprimer les lignes des cellules déplacées (cellules col B devenues vides).

Je cherche depuis un bon moment mais j'ai pas trouver le bon code pour l'instant.

Auriez-vous le bon code ?
Je joins un fichier test avec le résultat attendu.

Un grand merci comme d'habitude,
Entre temps, je continue mes recherches et tests.

Amicalement, lionel

 

[M12]

Bonjour,
Un test

 

[fanch55]

Salut Lionel,
un code vite fait :

Sub test()
Dim C As Range
    Do
        Set C = ActiveSheet.Columns("B").Find("Expediteur", Lookat:=xlPart)
        If C Is Nothing Then Exit Do
        C.Offset(1, -1) = C
        C.EntireRow.Delete
    Loop
End Sub

 

[Usine à gaz]

Bonjour M12, Bonjour fanch55,

Je vous remercie pour vos codes qui fonctionnent très bien.
Juste un p'tit truc (mais ça ne devrait pas arriver lol)

Si j'exécute plusieurs fois (par erreur) la macro, le code ce reproduit et c'est plus bon.
Est-il possible de limiter l'exécution du code à une seule fois ?

En tout cas, c'est déjà super comme ça
lionel

 

[job75]

Bonjour Lionel, M12, fanch55,

Le code de fanch55 est très simple mais la méthode prend beaucoup de temps.

J'ai recopié la plage B1:B35 sur 35 000 lignes et ajouté Application.ScreenUpdating = False dans la macro.

Chez moi sur Win 11 Excel 2019 elle s'exécute en 58 secondes.

Pour aller vite il faudra bien sûr utiliser un tableau VBA.

Edit : la macro de M12 s'exécute en 48 secondes.

A+

 

[Usine à gaz]

Bonjour Gérard,
Merci pour les infos.
lionel

 

[Lone-wolf]

Hello Job75, M12, Usine à gaz (j'espère écologique)

Juste un petit coucou en vitesse. Ravi de vous relire

 

[Usine à gaz]

Bonjour Mon Wolf préféré car le seul que je connaisse
Content de voir ton message.
Tu vas bien ?
Bon WE

 

[Robert]

Bonjour le fil, bonjour le forum,

Une autre proposition :

Sub MacroRobert()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim TD() As Variant 'déclare la variable TD (Tableau Destination)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)

Set O = Worksheets("Feuil_test") 'définit l'onglet O
DL = O.Cells(Application.Rows.Count, "B").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne B de l'onglet O
TS = O.Range("B1:B" & DL) 'définit le tableau source TS
ReDim TD(DL, 1 To 2) 'redimensionne le tableau destination TS
For I = 1 To DL 'boucle sur toutes les lignes I du tableau source
    If TS(I, 1) = "" Then 'condition : si la donnée ligne I colonne 1 de TS est vide
        J = IIf(I = 1, 1, I - K) 'définit la variable J (pour éviter d'avoir deux lignes vides entre deux blocs)
        TD(J, 1) = TS(I + 1, 1) 'récupère dans la ligne J colonne 1 de TD la donnée ligne I + 1 colonne 1 de TS
        TD(J, 2) = TS(I + 2, 1) 'récupère dans la ligne J colonne 2 de TD la donnée ligne I + 2 colonne 1 de TS
        TD(J + 1, 1) = "" 'récupère du vide dans la ligne J + 1 colonne 1 de TD
        TD(J + 1, 2) = TS(I + 3, 1) 'récupère dans la ligne J + 1 colonne 2 de TD la donnée ligne I + 3 colonne 1 de TS
        TD(J + 2, 1) = "" 'récupère du vide dans la ligne J + 2 colonne 1 de TD
        TD(J + 2, 2) = TS(I + 4, 1) 'récupère dans la ligne J + 2 colonne 2 de TD la donnée ligne I + 4 colonne 1 de TS
        K = K + 1 'incrémente K
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
O.Range("E1").Resize(DL, 2).Value = TD 'renvoie le tableau TD dans E1 redimensionnée (emplacement E1 à adapter)
End Sub

Je n'ai pas eu la chance comme Job de gagner un chronomètre atomique à Noël alors je ne te dirai pas combien de micro seconde met mon code pour dire qu'il s'en fout un peu du temps qui passe, mais je pense qu'il est suffisamment rapide pour convenir.

 

[job75]

Bonjour Lone-wolf, Robert,

Quel plaisir de te revoir Lone-wolf

Comme je le disais cette macro est très rapide :

Sub Restructurer()
Dim tablo, resu(), i&, n&
With ActiveSheet 'à adapter au besoin
    tablo = .Range("B1:B" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    ReDim resu(1 To UBound(tablo), 1 To 2)
    For i = 1 To UBound(tablo)
        n = n + 1
        If tablo(i, 1) Like "Expediteur*" Then resu(n, 1) = tablo(i, 1): i = i + 1
        resu(n, 2) = tablo(i, 1)
    Next
    '---restitution---
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1]
        If n Then .Resize(n, 2) = resu
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

Sur 35 000 lignes moins de 1/10ème de seconde.

A+

 

[job75]

Si j'exécute plusieurs fois (par erreur) la macro, le code ce reproduit et c'est plus bon.
Est-il possible de limiter l'exécution du code à une seule fois ?

Il suffit d'ajouter une ligne de code :

With ActiveSheet 'à adapter au besoin
    If Application.CountIf(.[B:B], "Expediteur*") = 0 Then Exit Sub 'sécurité
    '---

 

[Usine à gaz]

Bonjour Robert, Bonjour Gerard, Re-Bonjour au fil
Un grand merci pour vos retours
@ Robert : C'est presque ça, voici ci-dessous la photo du résultat attendu

@Gérard : Nickel comme d'habitude et instantané chez moi

Merci à vous,
lionel

 

[mapomme]

Bonjour à tous ,

Juste pour tous vous saluer. Une méthode sans tableau (c'est déjà pris ) basée sur des formules.
C'est assez rapide mais bien moins que la méthode de @job75 bien sûr.
Pour 35 000 lignes, l'exécution prend 0,4 s sur ma bécane.
Le code dans module1:

Sub ReArranger()
Const Source = "Feuil_test", Tempo = "Auxil"
Dim a, der&, deb
   deb = Timer: Application.ScreenUpdating = False
   If Application.CountIf(Sheets(Source).Range("b2:b5"), "Date :*") = 0 Then Exit Sub
   a = Application.Evaluate("=IFERROR(COLUMNS('" & Tempo & "'!A1),NA())")
   If IsError(a) Then ThisWorkbook.Worksheets.Add: ActiveSheet.Name = Tempo
   With Sheets(Tempo)
      .Columns("a:c").Clear
      Sheets(Source).Columns(2).Copy .Columns(1)
      der = .Cells(Rows.Count, 1).End(xlUp).Row
      .Range("b2:b" & der).FormulaR1C1 = "=IF(LEFT(RC[-1],2)=""ex"",RC[-1],IF(RC[-1]="""",NA(),""""))"
      .Range("c2:c" & der).FormulaR1C1 = "=IF(LEFT(R[1]C[-2],2)=""da"", R[1]C[-2],IF(LEFT(R[1]C[-2],2)=""me"", R[1]C[-2],IF(LEFT(R[1]C[-2],2)=""te"", R[1]C[-2],"""")))"
      .Range("b2:c" & der).Value = .Range("b2:c" & der).Value
      .Range("a2:a" & der).FormulaR1C1 = "=IF(ISNA(RC[1]),NA(),"""")"
      .Range("a2:a" & der).Value = .Range("a2:a" & der).Value
      On Error Resume Next
      .Range("a2:c" & der).Sort key1:=.Range("a2"), order1:=xlAscending, Header:=xlNo
      .Columns(1).Resize(der).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
      .Range("a1").Copy .Range("b1")
      .Columns("b:c").Copy Sheets(Source).Columns("b:c")
   End With
   Sheets(Source).Range("b:c").EntireColumn.AutoFit
   a = Application.Evaluate("=IFERROR(COLUMNS('" & Tempo & "'!A1),NA())")
   If Not IsError(a) Then Application.DisplayAlerts = False: Sheets(Tempo).Delete: Application.DisplayAlerts = True
   MsgBox Format(Timer - deb, "0.0\ sec.")
End Sub

 

[fanch55]

edit: mince, oublié encore de cliquer sur répondre ....

Si c'est une question de perf, le code ci-joint se fait en moins de 5 sd pour 35000 lignes :

Sub test()
Dim C As Range, F As Range
tma = Timer
Application.ScreenUpdating = False
    Set C = ActiveSheet.Columns("B").Find("Expediteur", Lookat:=xlPart)
    Do While Not C Is Nothing
        If F Is Nothing Then Set F = C
        C.Offset(1, -1) = C
        Set C = ActiveSheet.Columns("B").FindNext(C)
        If C.Address = F.Address Then Set C = Nothing
    Loop
    With ActiveSheet.Range(Cells(2, 2), Cells(ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row, 2))
        .AutoFilter Field:=1, Criteria1:="=expediteur*"
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With
  
MsgBox Timer - tma
End Sub

 

[Usine à gaz]

Bonjour mapomme, Re fanch55

Vos 2 codes fonctionnent également nickel.
Merci à vous.
lionel