Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Copier-insérer une ligne dans une BDD avec VBA

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
Signaler un problème avec ce contenu

3 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
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