Macro - Recopie de cellule jusqu'à la prochaine vide (sans incrémenter et en gardant mise en forme)

Marjo2 · 25 Juillet 2018

Bonjour le forum,

J'ai une succession d'étape à réaliser pour avoir un fichier exploitable.
Me mettant doucement au VBA j'ai essayé de mettre plusieurs macros mais elles ne fonctionnent pas :
Etape 1 : En colonne A, on recopie de haut en bas jusqu'à la référence suivante sans incrémenter et en gardant la mise en forme et on fait ça pour compléter chaque "vide"
Etape 2 : Insère une colonne à gauche de la colonne A (c'est ok)
Etape 3 : Copie les cellules en gras de la colonne B pour les mettre en colonne A (bien garder la même place)
Etape 4 : En colonne A, on recopie de haut en bas jusqu'à la référence suivante sans incrémenter les cellules et on fait ça pour compléter les "vides"
Etape 5 : Lancer la macro qui permet de supprimer les lignes vides de la colonne G
Etape 6 : Insère une colonne entre C et D
Etape 7 : Mettre "concatener(A;" ";B;" ";C) et tirer la formule vers le bas

Je vous joins un fichier avec le résultat qui devrait être obtenu.
Svp si vous pouvez mettre des commentaires en vert pour m'aider dans mon apprentissage, merci.

Staple1600 · 25 Juillet 2018

Bonsoir le fil, le forum, Marjo2

@Marjo2
Une façon de faire (si j'ai bien compris)

VB:

Sub Macro1()
'Déclarations variables
Dim Lig&, Ligg&, i&
'Dernière ligne non vide en colonne B
Lig = Cells(Rows.Count, 2).End(xlUp).Row
'insertion colonne
Application.ScreenUpdating = False
Columns("A:A").Insert Shift:=xlToRight
'Insertion formule
With Range("A5:A" & Lig)
.FormulaR1C1 = "=IF(COUNTA(RC[1]:RC[3])=2,RC[1],"""")"
.Value = .Value ' équivaut à Copier/Valeurs seules
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
For i = Lig To 5 Step -1
If Cells(i, 2).Font.Bold Then
Cells(i, 2).EntireRow.Delete 'suppression ligne en gras
End If
Next
Ligg = Cells(Rows.Count, 1).End(xlUp).Row
Columns("D:D").Insert Shift:=xlToRight
'concaténation
[D5].NumberFormat = "General": [D5].Value = [D5].Value * 1
Range("D5:D" & Ligg).Formula = "=A5&"" ""&B5&"" ""&C5"
'suppression lignes 1 et 2
Rows("1:2").Delete Shift:=xlUp
End Sub

Marjo2 · 26 Juillet 2018

C'est super merci et pour les commentaires aussi.
Bonne journée

Marjo2 · 31 Juillet 2018

Bonjour,

J'ai ajouté une suite à votre code pour finaliser la mise en forme. Cependant ça ne fonctionne pas, Excel plante.

Sub MiseEnforme()
'D?clarations variables
Dim Lig&, Ligg&, i&
'Derni?re ligne non vide en colonne B
Lig = Cells(Rows.Count, 2).End(xlUp).Row
'insertion colonne
Application.ScreenUpdating = False
Columns("A:A").Insert Shift:=xlToRight
'Insertion formule
With Range("A5:A" & Lig)
.FormulaR1C1 = "=IF(COUNTA(RC[1]:RC[3])=2,RC[1],"""")"
.Value = .Value ' ?quivaut ? Copier/Valeurs seules
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
For i = Lig To 5 Step -1
If Cells(i, 2).Font.Bold Then
Cells(i, 2).EntireRow.Delete 'suppression ligne en gras
End If
Next
Ligg = Cells(Rows.Count, 1).End(xlUp).Row
Columns("D").Insert Shift:=xlToRight
'concat?nation
[D5].NumberFormat = "General": [D5].Value = [D5].Value * 1
Range("D5" & Ligg).Formula = "=A5&"" ""&B5&"" ""&C5"
'suppression lignes 1 et 2
Rows("1:2").Delete Shift:=xlUp
Rows("2:2").Select 's?lectionne la ligne 2
Selection.AutoFilter 'mettre un filtre
ActiveSheet.Range("$A$2:$AC$65000").AutoFilter Field:=1, Criteria1:=Array( _
"0", "Dossier", "PORT"), Operator:=xlFilterValues 'S?lectionne les cellules "Dossier" et "PORT"
Rows("3:3").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=3
Selection.Delete Shift:=xlUp 'supprime
ActiveSheet.Range("$A$2:$AC$65000").AutoFilter Field:=1 'enleve le filtre
Range("B2").Select 'filtre en colonne B2
ActiveSheet.Range("$A$2:$AC$65000").AutoFilter Field:=2, Criteria1:= _
"Etat GTIQ711a" 'Sélectionne les lignes qui contiennent "Etat GTIQ711a"
Rows("26:26").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=6
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$2:$AC$65000").AutoFilter Field:=2 'supprime
ActiveWindow.SmallScroll Down:=-6
Columns("B:B").ColumnWidth = 7
Columns("C:C").ColumnWidth = 7
Columns("D").ColumnWidth = 20
Columns("E:E").ColumnWidth = 7
Columns("F:F").ColumnWidth = 3.22
Columns("G:G").ColumnWidth = 20
Columns("H:H").ColumnWidth = 0.88
Range("N2").Select 'S?lectionne en N2
ActiveSheet.Range("$A$2:$AG$1002").AutoFilter Field:=14, Criteria1:="<>"
Rows("26:26").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Range("N2").Select
ActiveSheet.Range("$A$2:$AG$65000").AutoFilter Field:=14
ActiveWindow.SmallScroll Down:=-3
Range("B2").Select 'en colonne B2 je fais un filtre pour supprimer les cellules "vides" => mais qui ne le sont pas vraiment, il y a des espaces
ActiveSheet.Range("$A$2:$AD$967").AutoFilter Field:=2, Criteria1:="="
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("B2").Select
ActiveSheet.Range("$A$2:$AD$65000").AutoFilter Field:=2
Range("C2").Select 'je supprime les "vides de la colonen C
ActiveSheet.Range("$A$2:$AD$65000").AutoFilter Field:=3, Criteria1:="="
Range("C33").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("C2").Select
ActiveSheet.Range("$A$2:$AD$65000").AutoFilter Field:=3
ActiveWindow.SmallScroll Down:=-9
Range("D3").Select 'je recalcule la formule concatener
Application.Calculation = xlAutomatic

End Sub

Staple1600 · 31 Juillet 2018

Bonsoir le fil, le forum

@Marjo2
Excel plante...
C'est vague, cela. Tu peux préciser quelle partie du code fait planter Excel
(quelle ligne VBA)
Et peux-tu rejoindre un fichier Excel exemple "actualisée, stp ?

PS: Suggestion en passant; utilises les balises BBCODE pour rendre ton message plus lisible
En faisant comme ci-dessous
[CODE=VB]
Sub NomMacro()
'Lignes de code VBA
'Lignes de code VBA
End Sub
[/CODE]
Ce qui donne le résultat suivant

VB:

Sub NomMacro()
'Lignes de code VBA
'Lignes de code VBA
End Sub

Marjo2 · 1 Août 2018

Bonjour,

Alors j'ai d'autres onglets sur le fichier excel. Le fichier a beaucoup plus de ligne que le document envoyé pour test.
Quand je lance uniquement la macro que vous avez proposé ca plante.
Mon fichier fait 799Ko.

En plus j'ai écrit à la suite du code que vous m'avez donné en utilisant l'enregistrement auto.
Mon code ajouté c'est la partie en rouge. J'ai voulu :
- supprimer les lignes qui contiennent "DOSSIER" et "PORT" et "Etat GTIQ711a", mots qui se situent en colonne A
(donc en enregistrement automatique, j'ai filtré, sélectionné, supprimé et enlevé le filtre)
- ensuite j'ai ajusté la taille des colonnes
- j'ai supprimé les espaces que j'ai en colonne B et C puis recalculé la formule concatener.

Macro - Recopie de cellule jusqu'à la prochaine vide (sans incrémenter et en gardant mise en forme)

Marjo2

XLDnaute Occasionnel

Pièces jointes

Staple1600

XLDnaute Barbatruc

Marjo2

XLDnaute Occasionnel

Marjo2

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

Marjo2

XLDnaute Occasionnel

Discussions similaires