Dupliquer données via combo

[cheyenne63]

Bonjour
En feuille «BDFT» , ma base de données (tri alphabétique sur la colonne A).
Je voudrais qu’après l’ouverture de l’USF (bouton feuille 2) et après avoir fait un choix d’une valeur dans le combo, ça duplique (via le bouton «Valider») les valeurs associées à ce choix avec en colonne A la nouvelle désignation (indiquée dans le textbox).
Deux contraintes :
- La macro ne doit pas fonctionner (message spécifique) si le textbox est vide (message spécifique)
- La macro ne doit pas fonctionner (autre message spécifique) si le textbox est égal à une valeur déjà présente dans la colonne A de « BDFT »

Pour plus de clarté, j’ai inséré un exemple dans une 3° feuille avec en jaune les nouvelles lignes insérées après duplication de « Désignation 4 »

Merci d’avance et bonne journée

 

[thebenoit59]

Re : Dupliquer données via combo

Bonjour Cheyenne.

Je te joins le fichier modifié.

Le code pour ne pas télécharger le fichier :

Private fBD As Object, d As Object, tBD

Private Sub CommandButton1_Click()
Dim c As String
    c = Me.Designation.Text
    'On extrait dans un nouveau tableau les lignes du premier tableau en fonction du critère, Array(1,2,3) désigne les trois colonnes du tableau
    t = Application.Index(tBD, Application.Transpose(Split(d(c), ":")), Array(1, 2, 3))
    With fBD
    'On insère le nombre de ligne selon l'index -1 (ligne vide)
    .Rows(2).Resize(UBound(t) - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
    'On supprime le remplissage
    .Rows(2).Resize(UBound(t) - 1).Interior.Pattern = xlNone
    'On note les valeurs à partir de A2
    .Range("a2").Resize(UBound(t) - 1, 3).Value = t
    'On modifie la désignation en fonction de TextBox
    .Range("a2").Resize(UBound(t) - 1, 1).Value = Me.TextBox1.Value
    End With
    Unload Me
    UserForm1.Show
End Sub

Private Sub Designation_Change()
    Activer_Bouton
End Sub

Private Sub TextBox1_Change()
    'On vérifie que le texte n'existe pas dans le dico
    If d.exists(Me.TextBox1.Value) Then Me.CommandButton1.Enabled = False: MsgBox "Désignation existante", vbCritical: Exit Sub
    'On lance la procédure qui active le bouton
    Activer_Bouton
End Sub

Private Sub Activer_Bouton()
    'Si les deux valeurs sont remplies on active le bouton
    With Me
    If .Designation.Text <> "" And .TextBox1.Text <> "" Then
    .CommandButton1.Enabled = True
    Else: .CommandButton1.Enabled = False
    End If
    End With
End Sub

Private Sub UserForm_Initialize()
Dim i As Integer
   Set fBD = Sheets("BDFT")
   'Mise sous forme de tableau de la zone à traiter
   tBD = fBD.Range("A2:C" & fBD.[A65000].End(xlUp).Row)
   Set d = CreateObject("scripting.dictionary")
   'On boucle le tableau sur la première colonne
   For i = LBound(tBD) To UBound(tBD)
    'dOuv(1) = dOuv(1) & i + 1 & "|"
    d(tBD(i, 1)) = d(tBD(i, 1)) & i & ":" 'On extrait les numéros de ligne en item du dico
  Next i
  Me.Designation.List = d.keys
  Me.CommandButton1.Enabled = False 'On désactive le bouton valider
End Sub

 

[cheyenne63]

Re : Dupliquer données via combo

Bonjour benoît
Ça me semble parfait
je vais étudier ça et sympa en plus pour les explications jointes, ça va beaucoup m'aider pour progresser
Merci beaucoup

 

[cheyenne63]

Re : Dupliquer données via combo

Benoît s'il te plait,
Comment faire pour intégrer les nouvelles valeurs à la suite des autres dans la feuille BDFT plutôt qu'en début de base en A2 ?
D'avance merci

 

[thebenoit59]

Re : Dupliquer données via combo

J'avais suivi le résultat dans ton dernier onglet .
Il sera plus simple d'insérer les résultats à la fin (pas d'insertions de lignes).

Private Sub CommandButton1_Click()
Dim c As String, i As Long
    c = Me.Designation.Text
    'On extrait dans un nouveau tableau les lignes du premier tableau en fonction du critère, Array(1,2,3) désigne les trois colonnes du tableau
    t = Application.Index(tBD, Application.Transpose(Split(d(c), ":")), Array(1, 2, 3))
    With fBD
    'Définition de la ligne d'insertion
    i = .[A65000].End(xlUp).Row + 1
    'On note les valeurs à partir de A2
    .Range("a" & i).Resize(UBound(t) - 1, 3).Value = t
    'On modifie la désignation en fonction de TextBox
    .Range("a" & i).Resize(UBound(t) - 1, 1).Value = Me.TextBox1.Value
    End With
    Unload Me
    UserForm1.Show
End Sub

 

[cheyenne63]

Re : Dupliquer données via combo

Merci beaucoup Benoît, c'est parfait et très clair.
Merci encore

 

[GADENSEB]

Re : Dupliquer données via combo

Hello
cette méthode me tente bien et le code à l'air super.... j'ai un peu la mm demande.
J'enregiste des données dans une Bdd via un usf.

et je voudrais que si une case à cocher est valider, au moment de l'implantation des données deux lignes soit créer avec seulement une donnée différente ente ces deux lignes.
est-ce clair comme explication ?

est-ce que cela correspond au code?

si ok je mettrais mon code.

Bonne am

sEb

 

[thebenoit59]

Re : Dupliquer données via combo

Bonjour Gadenseb.
Je vois ce que tu souhaites faire.
Peux-tu fournir un fichier déjà imaginé avec ton UF pour y jeter un oeil ?

 

[GADENSEB]

Re : Dupliquer données via combo

Hello
Merci de ton aide
La saisie se dans l'onglet INTERFACE avec le Bouton saisie en haut

Du coup, il me faut si le checkbox ...

IF CB_Double= false then
- Je lance l'import de l'import des données
end if

if IF CB_Double= true then
- Je lance l'import de l'import des données
- Je copie la mm ligne qui vient d'étre importer mais :
         Je rajoute +1 à CODE (Onglet COMPTES - colonneA)
         Je change BUDGETREEL : on remplace BUDGET par REEL (Onglet COMPTES -Colonne E)

Macro d'import :

Private Sub Bt_Validation_Click()
'Enregistre les données dans la BDD
Dim LastLigne As Integer

'Fige l'écran pendant l'éxécution de la macro
Application.ScreenUpdating = False

' Réglage du recalcul sur mode manuel
Application.Calculation = xlCalculationManual

'Texte PopUp
TexteDate = "En date du : " & DATESAISIE
Textecompte = "Sur le Compte : " & COMPTE
TexteBR = "En : " & BUDGETREEL
TexteDépenses = "Pour la dépense : " & LIBELLE

If DEBIT <> "" Then
TexteMtt = "Pour un montant de : " & DEBIT & " €"
Else: TexteMtt = "Pour un montant de : " & CREDIT & " €"
End If

TextePopUp = Chr(10) & TexteDate & Chr(10) & Textecompte & Chr(10) & TexteBR & _
             Chr(10) & TexteDépenses & Chr(10) & TexteMtt

If MsgBox("Ajouter une nouvelle Ligne ? " & Chr(10) & TextePopUp, vbYesNo, _
    " Demande de confirmation d'ajout ") = vbYes Then
 
  Set f = Sheets("COMPTES")
  LastLigne = Sheets("COMPTES").Range("a65536").End(xlUp).Row + 1

f.Cells(LastLigne, 1) = Me.CODE
f.Cells(LastLigne, 2) = CDate(Me.DATESAISIE)
f.Cells(LastLigne, 4) = Me.MOIS
f.Cells(LastLigne, 5) = Me.BUDGETREEL
f.Cells(LastLigne, 6) = Me.COMPTE
f.Cells(LastLigne, 7) = Me.POSTE
f.Cells(LastLigne, 10) = Me.NUMERO
f.Cells(LastLigne, 11) = Me.LIBELLE
f.Cells(LastLigne, 12) = Me.MODERGT
f.Cells(LastLigne, 15) = Me.BQ
If DEBIT <> "" Then
f.Cells(LastLigne, 16) = CCur(Me.DEBIT)
End If
If CREDIT <> "" Then
f.Cells(LastLigne, 17) = CCur(Me.CREDIT)
 End If
End If

Du coup, est-ce que ma demande est claire ?
Merci bonne journée

Seb

 

[GADENSEB]

Re : Dupliquer données via combo

HEllo thebenoit59
Tu as une idée sur mon soucis ?

Bonne am

 

[thebenoit59]

Re : Dupliquer données via combo

Bonjour Gandenseb.
Cela ne sera pas bien compliqué, mais je n'ai pas encore pris le temps de me plonger dedans.

 

[GADENSEB]

Re : Dupliquer données via combo

Pas de soucis

 

[GADENSEB]

Re : Dupliquer données via combo

hello
Sniff sniff
pas d'idées?
Bonne journée
Seb

 

[GADENSEB]

Re : Dupliquer données via combo

Hello
J'ai essayé de voir comment adapter ton code
On se base sur quoi ?
on injecte une ligne puis On reprend la dernière ligne créer et on implante une nouvelle ligne ?
ou on injecte les 2 lignes en mm temps ?

Bonne am

Seb

 

[thebenoit59]

Re : Dupliquer données via combo

Bonjour Seb.

Désolé pour le long retard.
Tu peux utiliser le code suivant, à coller à la suite de ton code d'importation :

If CB_Double.Value = True Then
f.Rows(LastLigne).Copy f.Cells(LastLigne + 1, 1)
f.Cells(LastLigne + 1, 1).Value = f.Cells(LastLigne + 1, 1) + 1
f.Cells(LastLigne + 1, 5).Value = "REEL"
End If