MACRO - Insertion/Couper /RECOPIE selon conditions

Marjo2

XLDnaute Occasionnel
Bonjour forum,

Je suis dans l'urgence et vient demander votre aide.
Un code VBA est nécessaire car la masse d'information a traité est importante.

L'onglet EXPORT correspond au résultat brut que l'on me donne.
Pour arriver à l'onglet RESULTAT A OBTENIR, j'ai fait :
- insertion d'une colonne entre B et C
- Couper de la colonne B, les cellules qui sont en majuscule (ou texte) et coller dans cette colonne nouvellement créer
- Recopie de haut en bas jusqu'à la prochaine cellule non vide

- insertion d'une colonne entre A et B
- Couper de la colonne A, les cellules de moins de 4 caractères pour les coller dans cette colonne nouvellement créer
- Recopie de haut en bas jusqu'à la prochaine cellule non vide

- Supprimer les lignes dont les cellules E sont vides.

Quelqu'un pour m'aider ?
 

Pièces jointes

  • Aide Mise en forme.xlsx
    15.4 KB · Affichages: 12

youky(BJ)

XLDnaute Barbatruc
VB:
Sub Marjo()
    Columns(2).Insert Shift:=xlToRight
    Columns(4).Insert Shift:=xlToRight
For lig = 1 To [A65000].End(3).Row
If Cells(lig, 5) = "" Then num = Cells(lig, 1): bbb = Cells(lig, 3): lig = lig + 1
If IsNumeric(Cells(lig, 3)) Then Cells(lig, 2) = Cells(lig, 1): Cells(lig, 1) = num: Cells(lig, 4) = bbb
If Not IsNumeric(Cells(lig, 3)) Then Cells(lig, 4) = Cells(lig, 3): Cells(lig, 3) = ""
Next
For lig = [A65000].End(3).Row To 1 Step -1
If Cells(lig, 5) = "" Then Rows(lig).Delete
Next
End Sub
Bonjour Marjo,
Voici le fichier avec la macro
Bruno
 

Pièces jointes

  • Aide Mise en forme (1).xlsm
    26.4 KB · Affichages: 11

youky(BJ)

XLDnaute Barbatruc
Remplacer la macro par celle-ci
difficile pour moi de faire mieux.
Dans tous les cas il faut supprimer et déplacer des données.
PS je fais pour 65000 lignes, si plus faut le signaler….
Bruno
VB:
Sub Marjo()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    Columns(2).Insert Shift:=xlToRight
    Columns(4).Insert Shift:=xlToRight
bas = [A65000].End(3).Row
[D1:D65000].Value = [C1:C65000].Value
For lig = 1 To bas
If Cells(lig, 5) = "" Then num = Cells(lig, 1): bbb = Cells(lig, 3): lig = lig + 1
If IsNumeric(Cells(lig, 3)) Then Cells(lig, 2) = Cells(lig, 1): Cells(lig, 1) = num: Cells(lig, 4) = bbb
If Not IsNumeric(Cells(lig, 3)) Then Cells(lig, 3) = ""
Next
For lig = bas To 1 Step -1
If Cells(lig, 5) = "" Then Rows(lig).Delete
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 707
Messages
2 081 734
Membres
101 809
dernier inscrit
HADER2024