Copier-insérer une ligne dans une BDD avec VBA

Le
Emile63
Bonjour à tous,

Sur une base de données contenant des noms | genre | langage | (sur 3 =
colonnes) je me trouve avec toute une série d'enregistrements simples =
qui ont un double genre par exemple:


Pierre | masc | CH
Dominique | masc, fém | FRA <-- Ici
Emile | masc | FRA
Pauline | fém | ITA

et donc je souhaiterais que mon code fasse une boucle sur la base de donn=
ées et qu'à chaque fois que le genre double est détect=
il sélectionne la ligne (juste les 3 colonnes, pas toute la ligne =
de la feuille) et qu'il l'insert & copie juste en dessous tout en corrigean=
t les genres, ligne 1 [masc] ligne 2 [fém] et éffacement de [masc=
, fém]
Et ainsi de suite jusqu'à la fin de la base.

Je travail autour du code suivant mais je cale un peu pour sélectionne=
r la ligne
, il y a de l'idée mais ça ne fonctionne pas du tout :-(

Je vous remercie d'avance pour votre aide et pour votre sollicitude.
Cordialement,
Emile

--
Sub Copier_Sur_Séléction()
'Sur une zone sélectionnée à la souris.
'Pourrait éventuellement être améliorer 'avec CurrentRegion.=
Select'

Dim Cel As Range
Application.ScreenUpdating = False
For Each Cel In Selection
If Cel.Value = "m,f" Then
Cel(Target.Resize(Cel.Rows.Count, Cel.Columns.Count - 2).Se=
lect
Selection.Copy
Cel.Replace What:="m,f", Replacement:="m"
Cel.EntireRow.Insert xlShiftDown
Cel.Replace What:="m", Replacement:="f"
End If
Next
Application.ScreenUpdating = True
End Sub
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Michd
Le #26473778
Bonjour
'Dans le haut du module,
'la comparaison du texte ne tient plus compte
'de la casse du texte de la cellule.
Option Compare Text
'---------------------------------------------------------
Sub test()
Dim Rg As Range, C As Range
Dim A As Long
'Nom feuille et de la plage de cellules à adapter
With Worksheets("Feuil1")
Set Rg = .Range("A1:C" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
For Each C In Rg.Columns(2).Cells
sss = C.Address
A = A + 1
If C.Value = "masc, fém" Then
Rg.Rows(A + 1).Insert
Rg.Rows(A).Resize(2).FillDown
C.Value = "masc"
C.Offset(1).Value = "fém"
End If
Next
End Sub
'---------------------------------------------------------
MichD
Michd
Le #26473783
J'ai omis cette ligne de code dans la section de la procédure :
If C.Value = "masc, fém" Then
Rg.Rows(A + 1).Insert
Rg.Rows(A).Resize(2).FillDown
C.Value = "masc"
C.Offset(1).Value = "fém"
A = A -1 '<=============== End If
MichD
Emile63
Le #26473803
Le jeudi 3 mai 2018 12:07:58 UTC+2, Michd a écrit :
Bonjour
'Dans le haut du module,
'la comparaison du texte ne tient plus compte
'de la casse du texte de la cellule.
Option Compare Text
'---------------------------------------------------------
Sub test()
Dim Rg As Range, C As Range
Dim A As Long
'Nom feuille et de la plage de cellules à adapter
With Worksheets("Feuil1")
Set Rg = .Range("A1:C" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
For Each C In Rg.Columns(2).Cells
sss = C.Address
A = A + 1
If C.Value = "masc, fém" Then
Rg.Rows(A + 1).Insert
Rg.Rows(A).Resize(2).FillDown
C.Value = "masc"
C.Offset(1).Value = "fém"
End If
Next
End Sub
'---------------------------------------------------------
MichD

Bonjour MichD et merci pour votre aide.
Cordialement.
Emile
Publicité
Poster une réponse
Anonyme