Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Déplacer un groupe de cellules

Usine à gaz

XLDnaute Barbatruc
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
 

Pièces jointes

  • test.xlsm
    13.9 KB · Affichages: 10
Dernière édition:
Solution
Bonjour Lone-wolf, Robert,

Quel plaisir de te revoir Lone-wolf

Comme je le disais cette macro est très rapide :
VB: 
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...
Trier par date Trier par votes

fanch55

XLDnaute Barbatruc
Salut Lionel,
un code vite fait :
VB: 
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
 
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
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+
 
Dernière édition:
Vote positif 0 Vote négatif

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

Une autre proposition :
VB: 
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.
 
Dernière édition:
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Bonjour Lone-wolf, Robert,

Quel plaisir de te revoir Lone-wolf

Comme je le disais cette macro est très rapide :
VB: 
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+
 
Vote positif 0 Vote négatif
Solution

mapomme

XLDnaute Barbatruc
Supporter XLD
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:
VB: 
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
 

Pièces jointes

  • Usine à gaz- réarranger- v1.xlsm
    444.3 KB · Affichages: 2
Vote positif 0 Vote négatif

fanch55

XLDnaute Barbatruc
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 :
VB: 
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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

D
  • Question
XL 2021 Déplacer un saut de page (manuel ou pas)
Réponses
4
Affichages
200
vgendron
  • Résolu(e)
XL 2021 Supprimer les lignes qui contiennent des cellules vides dans les colonnes "A à M" à partir de la ligne 5
Réponses
6
Affichages
578
Usine à gaz
  • Résolu(e)
XL 2021 Compter le nombre de cellules qui contiennent la date d'aujourd'hui
2
Réponses
17
Affichages
1 K
job75
  • Question
Microsoft 365 Remplir cellules à partir de plusieurs fichiers Excel d'un dossier
2
Réponses
17
Affichages
500
alexga78
A
  • Résolu(e)
XL 2021 affectation et classement de mes appels selon contenu des cellules en colonnes J ou L ou M
2 3
Réponses
30
Affichages
2 K
Usine à gaz
  • Résolu(e)
XL 2021 Extraire et mettre en col G le premier N° trouvé si son premier chiffre est différent de 0
2
Réponses
17
Affichages
694
Usine à gaz
Z
  • Question
XL 2016 Macro pour copier plusieurs cellules vers un fichier :(
Réponses
3
Affichages
303
zendb
Z
L
  • Résolu(e)
Microsoft 365 Aide : Colorer une cellule en fonction de sa valeur
Réponses
2
Affichages
315
Leo98
L
  • Résolu(e)
XL 2021 Affecter la valeur "ok" en colonne "F" uniquement sur les lignes visibles
Réponses
6
Affichages
528
Usine à gaz
  • Résolu(e)
XL 2021 Calendrier : à l'affichage ne pas sélectionner de date
2
Réponses
29
Affichages
1 K
Usine à gaz
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…