Macro dupliquant une ligne si une cellule contient tel caractère Résolu

Question

Bonjour,

Je reviens vers vous pour un problème dont je ne maitrise pas du tout la résolution !

Il s'agit de créer un script VBA qui effectuerait l'action suivante sur la même feuille :

Partir de la ligne 2
Si en A2 figure le mot "MOT_1" ajouter au mot de B2 le suffixe "_A"
Puis copier toute la ligne et l'insérer en dessous
Et ajouter au mot de B3 de la ligne collée le suffixe "_B"
Puis rechercher ainsi de suite tous les mots "MOT_1" dans les lignes suivantes de la colonne A et répéter l'opération...

Pour les suffixes, je ne sais pas ce qui est le plus logique, ou simple
Copier la ligne avant de la dupliquer puis renommer B2
Ou remplacer le "_A" de B3 par "_B" ?


Merci
Lo.

via55 · Answer

Bonsoir dhaze,

Essaie cette macro

Sub ajout()
Dim DernLigne As Long
DernLigne = Range("A" & Rows.Count).End(xlUp).Row
For n = DernLigne To 2 Step -1
If Range("A" & n) = "MOT_1" Then
    Rows(n & ":" & n).Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.Insert Shift:=xlDown
    Range("B" & n).Select
    ActiveCell.FormulaR1C1 = Range("B" & n).Value & "_A"
     Range("B" & n + 1).Select
    ActiveCell.FormulaR1C1 = Range("B" & n + 1).Value & "_B"
    End If
    Next
End Sub

Cdlmnt
 
"L'imagination est plus importante que le savoir."    A. Einstein

dhaze · Answer

Il y a dans la copie complète de la ligne des informations redondantes dans certaines colonnes.

Peut-on par exemple exclure certaines colonnes de la copie afin d'avoir une cellule vide après collage et/ou y ajouter un caractère générique ?

Et suite dans cette macro, peut-on recombiner les colonnes (Ex: A en Y et B en P etc...) sur une nouvelle veuille ?

via55 · Answer

Re,

quelles sont les colonnes à exclure ?
quelle caractère générique est à inscrire et où

je ne comprends pas ce que tu entends par "recombiner A en Y " ?? tu veux dire les placer dans un autre ordre sur une nouvelle feuille ?
si c'est cela c'est possible à condition de savoir exactement pour chaque colonne où la mettre

Cdlmnt

dhaze · Answer

Bonjour,

Oui, j'ai adapté ta macro comme cela :

Sub SiMonofaceDupliquerLigne()
Dim DernLigne As Long
DernLigne = Range("P" & Rows.Count).End(xlUp).Row
For n = DernLigne To 2 Step -1
If Range("P" & n) = "Monoface" Then
Rows(n & ":" & n).Select
Application.CutCopyMode = False
Selection.Copy
Selection.Insert Shift:=xlDown
Range("Y" & n).Select
ActiveCell.FormulaR1C1 = Range("Y" & n).Value & "_A"
Range("Y" & n + 1).Select
ActiveCell.FormulaR1C1 = Range("Y" & n + 1).Value & "_B"
End If
Next
End Sub

Et dans la recopie des lignes je souhaite exclure les colonnes A à G, donc vides et ajouter un # dans les colonnes A et F. 

Puis, la création de la deuxième feuille en reportant certaines colonnes, je ne sais pas encore combien de colonnes viendraient s'intercaler entre G et Y.
Mais ce sera bien une recopie des colonnes A à H sûr, et Y en "quelque-chose"...

Lo.

via55 · Answer

Bonjour

Si j'ai bien compris, rajoutes ces lignes juste après Selection.Insert Shift:=xlDown dans la macro :

Range("A" & n + 1 & ":G" & n + 1).SelectSelection.ClearContentsRange("A" & n + 1) = "#"Range("F" & n + 1) = "#"

Pour la recopie sur une autre feuille il faut prévoir une macro de ce style

Sub recopie()
    Sheets("Feuil1").Select
    Columns("A:H").Select
    Selection.Copy
    Sheets("Feuil2").Select
    Range("A1").Select
    ActiveSheet.Paste
   Sheets("Feuil1").Select
    Columns("Y:Y").Select
    Selection.Copy
    Sheets("Feuil2").Select
    Range("Y1").Select
    ActiveSheet.Paste

End Sub

A adapter avec le nom des feuilles et les bonnes colonnes


Cdlmnt
 
"L'imagination est plus importante que le savoir."    A. Einstein

pijaku · Answer

Bonjour,

Lorsque vous placez du code sur notre forum, merci d'utiliser les balises code à votre disposition.
Le mode d'emploi (au cas ou) est ICI.

dhaze · Answer

J'ai encore pas mal d'interrogations sur la création d'une nouvelle feuille avec quelques spécificités prédéfinies...
Mais j'ouvrirais un nouveau sujet pour cela.

Pour l'instant, en ce qui me concerne, ce sujet est bien résolu.
Et au vu de l'aide précieuse qui m'a été apportée ici,
je ne pouvais décemment pas ne pas prendre un peu de temps pour remercier
les contributeurs de ce forum. Et tout particulièrement via55.
Sans oublier l'indulgence bienveillante du modérateur...

Mes compétences ne me permettent pas encore de pouvoir apporter ma pierre à cette édifice. Mais avec le temps et plus d'expérience, qui sait...

Encore un grand merci.

Lo.

dhaze · Answer

Salut à vous.

Je reviens sur cette macro...
C'était trop beau pour durer !

Les tableaux que l'on me fournit n'ont pas toujours la valeur "Monoface" dans la colonne "P" et le nom à modifier en "Y".

Peut-on sélectionner ces colonnes par la valeur de leurs en-têtes, en l'occurrence "Face" et "Nom de fichier", qui sont quelque part ligne 1 ?

Et petite subtilité, en dupliquant la ligne, renommée "Monoface" en "A" pour la première ligne et "B" pour la seconde.

Revoici la macro telle que je l'utilise :

Sub Si_monoface_dupliquer_ligne()
  Dim DernLigne As Long
  DernLigne = Range("P" & Rows.Count).End(xlUp).Row
  For n = DernLigne To 2 Step -1
    If Range("P" & n) = "Monoface" Then
      Rows(n & ":" & n).Select
      Application.CutCopyMode = False
      Selection.Copy
      Selection.Insert Shift:=xlDown
      Selection.Insert Shift:=xlDown
      Range("A" & n + 1 & ":G" & n + 1).Select
      Selection.ClearContents
      Range("A" & n + 1) = "#"
      Range("F" & n + 1) = "#"
      Range("Y" & n).Select
      ActiveCell.FormulaR1C1 = Range("Y" & n).Value & "_A"
      Range("Y" & n + 1).Select
      ActiveCell.FormulaR1C1 = Range("Y" & n + 1).Value & "_B"
    End If
  Next
End Sub

Par ailleurs.

J'ai trouvé chez Microsoft un petit code que je voudrais pouvoir
Utiliser en le modifiant sur la même principe.
Est-ce possible ?

StartRange = "P1" 'remplacer par valeur d'entête colone à copier
EndRange = "Y1" 'idem
  Set a = Range(StartRange, Range(StartRange).End(xlDown))
  Set b = Range(EndRange, Range(EndRange).End(xlDown))
Union(a, b).Select

Lo.

via55 · Answer

Bonsoir

Remplaces ta macro par celle ci

Sub Si_monoface_dupliquer_ligne()
Dim ColF As Integer
Dim colN As Integer
ColF = Rows(1).Find("Face", , , , xlByRows, xlPrevious).Column
colN = Rows(1).Find("Nom de fichier", , , , xlByRows, xlPrevious).Column
  Dim DernLigne As Long
  DernLigne = Columns(ColF).Find("*", , , , xlByColumns, xlPrevious).Row
  For n = DernLigne To 2 Step -1
    If Cells(n, ColF) = "Monoface" Then
      Rows(n & ":" & n).Select
      Application.CutCopyMode = False
      Selection.Copy
      Selection.Insert Shift:=xlDown
      Selection.Insert Shift:=xlDown
      Range("A" & n + 1 & ":G" & n + 1).Select
      Selection.ClearContents
      Range("A" & n + 1) = "#"
      Range("F" & n + 1) = "#"
      Cells(n, colN).Select
      ActiveCell.FormulaR1C1 = Cells(n, colN).Value & "_A"
      Cells(n + 1, colN).Select
      ActiveCell.FormulaR1C1 = Cells(n + 1, colN).Value & "_B"
    End If
  Next
End Sub

mais je ne comprends pas pourquoi les A et B sont décalés d'une ligne par rapport à Monoface; c'était comme cela dans ta macro d'origine je n'ai pas modifié

Par contre je ne saisis pas ce que tu veux dire par Et petite subtilité, en dupliquant la ligne, renommée "Monoface" en "A" pour la première ligne et "B" pour la seconde.  Peux tu être plus explicite

Cdlmnt

dhaze · Answer

Bonjour Via55,

Oui, déjà il y a une petite coquille dans mon post,
en recopiant la macro il y a deux fois la ligne:

"Selection.Insert Shift:=xlDown"
En la supprimant, ça fonctionne parfaitement.

Pour répondre à ta question

Cette macro traite les monofaces en en faisant de double faces. 
Dans ce tableau il y a des lignes doubles (A et B en "P", "*_A" et "*_B" en "Y") qui sont exclus par la macro. Et dont le nom en "Y" n'a pas d'extension "_A" ou "_B". Ce que la macro ajoute aussi.

Le but est que dans la colonne "P", puisque la ligne est dupliquée pour avoir une deuxième face, il faudrait remplacer "Monoface" par "A" dans la première ligne et "B" dans la second (celle dupliquée).

Ainsi il n'y aurait plus que des double faces, celle existantes, plus les monos dupliquées...

dhaze · Answer

Bonjour Via55,

Ton .Find() m'a bien trotter dans la tête, et je me disais...

Puis-je l'utiliser pour améliorer ma sélection de colonne ?

Au lieu d'un :

ActiveSheet.Range(ActiveSheet.Range("A65536").End(xlUp), "H1").Select
Remplacer "H1" par un Find dans Range(1:1) valeur="Un Mot"

Mais je ne sais pas comment le formuler.

Tout ce que j'ai pu lire sur les sélections de plages ou de "Find"
ne m'ont pas éclairé sur une solution de ce genre.

Bonne soirée.

Lo.

via55 · Answer

Bonsoir Dhaze
Essaie ceci:
Dim a As Integer
a = Rows(1).Find("Face", , , , xlByRows, xlPrevious).Column ' cherche la colonne où est Face en ligne 1 A ADAPTER
ActiveSheet.Range(ActiveSheet.Range("A65536").End(xlUp), Cells(1, a)).Select
 
Cdlmnt

dhaze · Answer

Via55 merci, grâce à ton aide le post traitement de mono faces fonctionne.

'Voir ci-dessus précédemment
La réplication partielle du tableau aussi.

Sub Photo()
	
	Dim Valeur_Fin As Integer  'Valeur "Nom de fichier"
	
	Call Si_trouve_monoface_dupliquer_ligne  'Duplication des monofaces en A et B
	
' Création des nouvelles feuilles spécifiques à la prise de vue
	
	Sheets.Add.Move After:=Sheets(Sheets.Count)
	Sheets(Sheets.Count).Name = "Tableau Photo"
	Sheets.Add.Move After:=Sheets(Sheets.Count)
	Sheets(Sheets.Count).Name = "PV via WIA"
	
' Sélection et copie des colonnes de base du tableau d'origine
	
	Sheets("Modèle").Select
	Valeur_Fin = Rows(1).Find("Nom de fichier", , , , xlByRows, xlPrevious).Column
	ActiveSheet.Range(ActiveSheet.Range("A65536").End(xlUp), Cells(1, Valeur_Fin)).Select
	Selection.Copy
	
' Recopie dans la nouvelle feuille
	
	Sheets("Tableau Photo").Select
	Range("A1").Select
	ActiveSheet.Paste
	
	Selection.PasteSpecial Paste:=xlPasteColumnWidths
	ActiveSheet.Paste
	
	Call Formatage_des_cellules  'Format des cellules (Style et couleurs)
	
' Création des nouvelles colonnes de données
	
	Sheets("Tableau Photo").Select
	Range("A1").End(xlToRight).Offset(0, 1).Select
	
End Sub
Je dois l'enrichir de colonnes systématiques.
Existe-il une solution en VBA pour appliquer dans des cellules une liste de cette forme :

LISTE	Titre_Col_X, Val_Col_X	Titre_Col_Y, Val_Col_Y	Titre_Col_Z, Val_Col_Z	Etc.../LISTE
Appliquer dans :

Range("A1").End(xlToRight).Offset(0, 1).Select
+---+-------------+-------------+-------------+|   | X (Select)  |      Y      |      Z      |+---+-------------+-------------+-------------+| 1 | Titre_Col_X | Titre_Col_X |  Val_Col_X  |+---+-------------+-------------+-------------+| 2 |  Val_Col_X  |  Val_Col_X  |  Val_Col_X  |+---+-------------+-------------+-------------+| 3 |  Val_Col_X  |  Val_Col_X  |  Val_Col_X  |+---+-------------+-------------+-------------+Etc...
Répliquer jusqu'a .End(xlDown) de la colonne précédant .Select

Bon WE
Lo.

via55 · Answer

Bonjour Dhaze

Si j'ai bien compris ta demande, en ayant dans une autre feuille la liste des titres des nouvelles colonnes et en face la valeur à mettre dans toute la colonne :

ActiveSheet.Range("A1").End(xlToRight).Offset(0, 1).Select
'dernière colonne remplie
Dim DernCol As Integer
DernCol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
' derniere ligne remplie de cette colonne
Dim Ligne As Long
Ligne = Columns(DernCol).Find("*", , , , xlByColumns, xlPrevious).Row
' nombre de colonnes à créer
nbcol = 3 ' A ADAPTER
' remplissage des colonnes
For n = 1 To nbcol
'titre en 1ere ligne récupéré en A1,A2 etc d'une feuille nommée DATA
Cells(1, DernCol + n) = Sheets("DATA").Range("A" & n)
For x = 2 To Ligne
' valeur dans les x lignes récupérée en B1, B2 etc de DATA
Cells(x, DernCol + n) = Sheets("DATA").Range("B" & n)
Next x
Next n
 
Bon WE également
Cdlmnt

dhaze · Answer

Coucou, la revoilà :-)

Cette fois, je pensais m'en sortir seule...
Mais ça ne fonctionne pas.

Alors, je me suis dit (à regret ;-), je vais en parler à mon débogueur préféré !


Sub Verif()
Application.ScreenUpdating = False
    
    Dim formule_verif As Integer
    formule_verif = Rows(1).Find("Vérif", , , , xlByRows, xlPrevious).Column
    Dim Der_Ligne As Long
    Der_Ligne = Columns(formule_verif).Find("*", , , , xlByColumns, xlPrevious).Row
    For n = Der_Ligne To 2 Step -1
        Rows(n & ":" & n).Select
        ActiveCell.FormulaR1C1 = "=IF(R[0]C[-2]=R[0]C[-1],""OK"",""!!!"")"
        If cell = "OK" Then
            cell.Interior.ColorIndex = 4
        ElseIf cell = "!!!" Then
            cell.Interior.ColorIndex = 3
        End If
    Next
    
Application.ScreenUpdating = True
End Sub

Une idée ?

via55 · Answer

Bonsoir Dhaze

Tu n'indiques pas quelle cellule doit avoir OK 
 If cell = "OK" Then
c'est soit  If cells (x,y)="OK"  avec le n° de ligne en variable x et le n° de colonne en variable y
soit If Activecell="OK" pour la cellule active

Plutôt celle-là don dans ton cas
et pour ne mettre l'activecell qu'une fois  tu peux utiliser With (dans les instructions qui suivent le. en début indique d'y ajoindre avant Activecell:

With ActiveCell
.FormulaR1C1 = "=IF(R[0]C[-2]=R[0]C[-1],""OK"",""!!!"")"
        If .Value = "OK" Then
           .Interior.ColorIndex = 4
        ElseIf cell = "!!!" Then
            .Interior.ColorIndex = 3
        End If
End With


Cdlmnt
 
"L'imagination est plus importante que le savoir."    A. Einstein

dhaze · Answer

Bonjour,

J'ai fait la modif, mais je pense qu'il y a un autre problème dans ce code.
Puisse que la colonne "Vérif" n'est pas encore remplie, mon "Der_Ligne" ne doit pas fonctionner. Faudrait y ajouter un "Offset(0, -1)" quelque part...
Pour la syntaxe, je cale.

Sub Verif()
	Dim formule_verif As Integer
	formule_verif = Rows(1).Find("Vérif", , , , xlByRows, xlPrevious).Column
	Dim Der_Ligne As Long
	Der_Ligne = Columns(formule_verif).Find("*", , , , xlByColumns, xlPrevious).Row
'Offset(0, -1) ???
	For n = Der_Ligne To 2 Step -1
		Rows(n & ":" & n).Select
		With ActiveCell
			.FormulaR1C1 = "=IF(R[0]C[-2]=R[0]C[-1],""OK"",""!!!"")"
			If .Value = "OK" Then
				.Interior.ColorIndex = 4
			ElseIf .Value = "!!!" Then
				.Interior.ColorIndex = 3
			End If
		End With
	Next
End Sub

Lo.

Macro dupliquant une ligne si une cellule contient tel caractère

17 réponses

Votre réponse

Discussions similaires