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

3 réponses
Avatar
Emile63
Bonjour =C3=A0 tous,

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

......
Pierre | masc | CH
Dominique | masc, f=C3=A9m | FRA <-- Ici
Emile | masc | FRA
Pauline | f=C3=A9m | ITA

et donc je souhaiterais que mon code fasse une boucle sur la base de donn=
=C3=A9es et qu'=C3=A0 chaque fois que le genre double est d=C3=A9tect=C3=
=A9 il s=C3=A9lectionne 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=C3=A9m] et =C3=A9ffacement de [masc=
, f=C3=A9m]
Et ainsi de suite jusqu'=C3=A0 la fin de la base.

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

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

--------------------------------------------
Sub Copier_Sur_S=C3=A9l=C3=A9ction()
'Sur une zone s=C3=A9lectionn=C3=A9e =C3=A0 la souris.=20
'Pourrait =C3=A9ventuellement =C3=AAtre am=C3=A9liorer 'avec CurrentRegion.=
Select'

Dim Cel As Range
Application.ScreenUpdating =3D False
For Each Cel In Selection
If Cel.Value =3D "m,f" Then
Cel(Target.Resize(Cel.Rows.Count, Cel.Columns.Count - 2).Se=
lect
Selection.Copy
Cel.Replace What:=3D"m,f", Replacement:=3D"m"
Cel.EntireRow.Insert xlShiftDown
Cel.Replace What:=3D"m", Replacement:=3D"f"
End If =20
Next =20
Application.ScreenUpdating =3D True
End Sub

3 réponses

Avatar
Michd
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
Avatar
Michd
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
Avatar
Emile63
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