XL 2019 Copie des données des différentes lignes sur une base de données

Y

YANNISE

XLDnaute Junior
salut le Forum ;

J’ai une macro que @Bernard_XLD m’a portée aide pour la développer, cette macro à l’usage de faire le transfert des données répartie sur plusieurs lignes à une base de données avec certaines conditions

Toutefois je voulais ajouter aux deux lignes existent une troisième ligne mais ça ne marche pas, pourrez-vous m’aider svp.

ci-après le code ainsi que le fichier Excel ci-joint
merci d'avance

VB: 
Sub Copy_3Lg()

      Dim Reponse As Byte
      Dim PL As Range, Cel As Range, Lettre$, Message$
      Dim Mavariable As String
    
      Set PL = Feuil1.Range("E3,G3,E6,G6,I6")
      For Each Cel In PL
            Select Case Cel.Address(False, False, xlA1)
                  Case "E3": Lettre = "'Commande'"
                  Case "G3": Lettre = "'Date'"
                  Case "E6": Lettre = "'Article'"
                  Case "G6": Lettre = "'Réf.'"
                  Case "I6": Lettre = "'Matricule'"

            End Select
            Select Case Cel.Text
                  Case Is = ""
                        Cel.Interior.Color = RGB(255, 46, 46)
                        If Message = "" Then Message = "Champ(s) non renseigné(s) :  " & vbLf & vbLf & Lettre Else Message = Message & ", " & Lettre
                  Case Else: Cel.Interior.ColorIndex = xlColorIndexNone
                  Range("E59,J59").Interior.Color = RGB(221, 235, 247)
            End Select
          
      Next Cel
      If Application.CountA(Feuil1.Range("E9,G9,I9")) > 0 Then
          Set PL = Feuil1.Range("E9,G9,I9")
          For Each Cel In PL
                Select Case Cel.Address(False, False, xlA1)
                      Case "E9": Lettre = "'Article 2'"
                      Case "G9": Lettre = "'Réf. 2'"
                      Case "I9": Lettre = "'Matricule 2'"
    
                End Select
                Select Case Cel.Text
                      Case Is = ""
                            Cel.Interior.Color = RGB(255, 46, 46)
                            If Message = "" Then Message = "Champ(s) non renseigné(s) :  " & vbLf & vbLf & Lettre Else Message = Message & ", " & Lettre
                      Case Else: Cel.Interior.ColorIndex = xlColorIndexNone
                      Range("E59,J59").Interior.Color = RGB(221, 235, 247)
                End Select
              
          Next Cel
      End If
      
          If Application.CountA(Feuil1.Range("E12,G12,I12")) > 0 Then
          Set PL = Feuil1.Range("E12,G12,I12")
          For Each Cel In PL
                Select Case Cel.Address(False, False, xlA1)
                      Case "E12": Lettre = "'Article 3'"
                      Case "G12": Lettre = "'Réf. 3'"
                      Case "I12": Lettre = "'Matricule 3'"
    
                End Select
                Select Case Cel.Text
                      Case Is = ""
                            Cel.Interior.Color = RGB(255, 46, 46)
                            If Message = "" Then Message = "Champ(s) non renseigné(s) :  " & vbLf & vbLf & Lettre Else Message = Message & ", " & Lettre
                      Case Else: Cel.Interior.ColorIndex = xlColorIndexNone
                      Range("E59,J59").Interior.Color = RGB(221, 235, 247)
                End Select
              
          Next Cel
      End If

      If Not Application.CountA(Feuil1.Range("E3,G3,E6,G6,I6")) = 5 Or (Application.CountA(Feuil1.Range("E9,G9,I9")) > 0 And Application.CountA(Feuil1.Range("E9,G9,I9")) < 3 Or Application.CountA(Feuil1.Range("E12,G12,I12")) < 3) Then

            MsgBox Message & vbLf & vbLf & vbLf & "Veuillez saisir le champ signalé (s) ", vbCritical + vbOKOnly, "Erreur de saisie"
          
      Else
        Feuil1.Range("E3,G3,E6,G6,I6,E9,G9,I9,E12,G12,I12").Interior.ColorIndex = xlColorIndexNone
        
            Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E3")
            Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G3")
          
            Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E6")
            Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G6")
            Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("I6")
          
          
            If Application.CountA(Feuil1.Range("E9,G9,I9")) = 3 Then
                Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E3")
                Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G3")
          
                Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E9")
                Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G9")
                Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("I9")
            End If
                  
            If Application.CountA(Feuil1.Range("E12,G12,I12")) = 3 Then
                Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E3")
                Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G3")
          
                Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E12")
                Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G12")
                Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("I12")
            End If
            
            Reponse = MsgBox(vbCr & "    " & "Les données ont bien été enregistrées" & vbCr & " " & vbCr & " " & "Voulez-vous effacer les champs de saisie ?" _
                        , vbInformation + vbYesNo, "Enregistrement effectué...")

            Dim i As Long, k As Long
                With Feuil2
                    k = 1
                    For i = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
                        If IsNumeric(.Range("A" & i)) And .Range("B" & i) <> "" Then
                        .Range("A" & i) = k
                            k = k + 1
                            Else
                          End If
                        Next i
                    End With
            If Reponse = 6 Then clear_dn_1
 
            End If
          
End Sub
 

Pièces jointes

  • Classeur1.xlsm
    32.3 KB · Affichages: 3
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour YANNISE,

Vos macros sont beaucoup trop compliquées, voyez le fichier joint et celles-ci :
VB: 
Sub Transfert()
Dim F1 As Worksheet, F2 As Worksheet, P As Range, lig&, c As Range, n
Set F1 = Feuil1
Set F2 = Feuil2
Set P = F1.[E6,G6,I6,E9,G9,I9,E12,G12,I12]
With Union(F1.[E3], F1.[G3], P)
    If Not .Find("", , xlValues) Is Nothing Then
        .SpecialCells(xlCellTypeBlanks).Select
        MsgBox "Renseignez la ou les cellule(s) sélectionnée(s)"
        Exit Sub
    End If
End With
If F2.FilterMode Then F2.ShowAllData 'si la feuille est filtrée
lig = F2.Cells(F2.Rows.Count, 1).End(xlUp).Row + 1
With F2.Cells(lig, 1).Resize(3)
    .FormulaR1C1 = "=N(R[-1]C)+1"
    .Value = .Value 'supprime les formules
End With
F2.Cells(lig, 2).Resize(3) = F1.[E3] 'commande
F2.Cells(lig, 3).Resize(3) = F1.[G3] 'date
For Each c In F2.Cells(lig, 4).Resize(3, 3)
    n = n + 1
    c = P.Areas(n)
Next
F2.Select 'facultatif
End Sub

Sub RAZ()
Feuil1.[E3,G3,E6,G6,I6,E9,G9,I9,E12,G12,I12].ClearContents
End Sub
A+
 

Pièces jointes

  • Classeur(1).xlsm
    22.7 KB · Affichages: 5
Dernière édition:
Vote positif 0 Vote négatif
Y

YANNISE

XLDnaute Junior
Merci pour votre intervention @job75 , mais l’objectif est de :
  • Faire copie les données depuis le formulaire (Feuil1) et les recopies sur la base de donne feuil2
  • Si un champ est vide alors un message d’alerte se déclenche afin de remplir les informations manquantes
  • Si seulement la première ligne est remplie mais la deuxième non alors les informations résignaient (ligne 1) seront transférés à la BD
  • La ligne doit être entièrement remplis si une cellule est vide alors un message d’alerte se déclenche.
  • Ligne 1 obligatoire mais ligne 2 ou 3 facultatif
Je vous invite à jeter un coup d'œil sur la première demande ici

Merci quand même.
 
Vote positif 0 Vote négatif
Y

YANNISE

XLDnaute Junior
Je suis arrivé à ajouter la troisième ligne à la macro mais le problème est quand la ligne 2 est vide et la ligne 3 est remplie alors le transfert des données ne doit pas exécuter car les données doivent être renseignées ligne par ligne respectivement

Pourriez-vous m’aider à résoudre ce problème SVP

Si la ligne 1 et 3 sont renseignées mais la ligne 2 non alors le message d’alerte se déclenche pour la saisi de la line avant d’abord

Merci d'avance

VB: 
Sub Copy_3Lg()

      Dim Reponse As Byte
      Dim PL As Range, Cel As Range, Lettre$, Message$
      Dim Mavariable As String
    
      Set PL = Feuil1.Range("E3,G3,E6,G6,I6")
      For Each Cel In PL
            Select Case Cel.Address(False, False, xlA1)
                  Case "E3": Lettre = "'Commande'"
                  Case "G3": Lettre = "'Date'"
                  Case "E6": Lettre = "'Article'"
                  Case "G6": Lettre = "'Réf.'"
                  Case "I6": Lettre = "'Matricule'"

            End Select
            Select Case Cel.Text
                  Case Is = ""
                        Cel.Interior.Color = RGB(255, 46, 46)
                        If Message = "" Then Message = "Champ(s) non renseigné(s) :  " & vbLf & vbLf & Lettre Else Message = Message & ", " & Lettre
                  Case Else: Cel.Interior.ColorIndex = xlColorIndexNone
                  Range("E59,J59").Interior.Color = RGB(221, 235, 247)
            End Select
          
      Next Cel
      'Ligne 1
      If Application.CountA(Feuil1.Range("E9,G9,I9")) > 0 Then
          Set PL = Feuil1.Range("E9,G9,I9")
          For Each Cel In PL
                Select Case Cel.Address(False, False, xlA1)
                      Case "E9": Lettre = "'Article 2'"
                      Case "G9": Lettre = "'Réf. 2'"
                      Case "I9": Lettre = "'Matricule 2'"
    
                End Select
                Select Case Cel.Text
                      Case Is = ""
                            Cel.Interior.Color = RGB(255, 46, 46)
                            If Message = "" Then Message = "Champ(s) non renseigné(s) :  " & vbLf & vbLf & Lettre Else Message = Message & ", " & Lettre
                      Case Else: Cel.Interior.ColorIndex = xlColorIndexNone
                      Range("E59,J59").Interior.Color = RGB(221, 235, 247)
                End Select
              
          Next Cel
      End If
      'Ligne 2
          If Application.CountA(Feuil1.Range("E12,G12,I12")) > 0 Then
          Set PL = Feuil1.Range("E12,G12,I12")
          For Each Cel In PL
                Select Case Cel.Address(False, False, xlA1)
                      Case "E12": Lettre = "'Article 3'"
                      Case "G12": Lettre = "'Réf. 3'"
                      Case "I12": Lettre = "'Matricule 3'"
    
                End Select
                Select Case Cel.Text
                      Case Is = ""
                            Cel.Interior.Color = RGB(255, 46, 46)
                            If Message = "" Then Message = "Champ(s) non renseigné(s) :  " & vbLf & vbLf & Lettre Else Message = Message & ", " & Lettre
                      Case Else: Cel.Interior.ColorIndex = xlColorIndexNone
                      Range("E59,J59").Interior.Color = RGB(221, 235, 247)
                End Select
              
          Next Cel
      End If

      If Not Application.CountA(Feuil1.Range("E3,G3,E6,G6,I6")) = 5 Or (Application.CountA(Feuil1.Range("E9,G9,I9")) > 0 And Application.CountA(Feuil1.Range("E9,G9,I9")) < 3) Then

            MsgBox Message & vbLf & vbLf & vbLf & "Veuillez saisir le champ signalé (s) ", vbCritical + vbOKOnly, "Erreur de saisie"
            
     ElseIf Not Application.CountA(Feuil1.Range("E3,G3,E6,G6,I6")) = 5 Or (Application.CountA(Feuil1.Range("E12,G12,I12")) > 0 And Application.CountA(Feuil1.Range("E12,G12,I12")) < 3) Then

            MsgBox Message & vbLf & vbLf & vbLf & "Veuillez saisir le champ signalé (s) ", vbCritical + vbOKOnly, "Erreur de saisie"
    
          
      Else
        Feuil1.Range("E3,G3,E6,G6,I6,E9,G9,I9,E12,G12,I12").Interior.ColorIndex = xlColorIndexNone
        
            Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E3")
            Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G3")
          
            Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E6")
            Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G6")
            Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("I6")
          
          
            If Application.CountA(Feuil1.Range("E9,G9,I9")) = 3 Then
                Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E3")
                Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G3")
          
                Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E9")
                Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G9")
                Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("I9")
            End If
                  
            If Application.CountA(Feuil1.Range("E12,G12,I12")) = 3 Then
                Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E3")
                Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G3")
          
                Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E12")
                Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("G12")
                Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("I12")
            End If
            
            Reponse = MsgBox(vbCr & "    " & "Les données ont bien été enregistrées" & vbCr & " " & vbCr & " " & "Voulez-vous effacer les champs de saisie ?" _
                        , vbInformation + vbYesNo, "Enregistrement effectué...")

            Dim i As Long, k As Long
                With Feuil2
                    k = 1
                    For i = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
                        If IsNumeric(.Range("A" & i)) And .Range("B" & i) <> "" Then
                        .Range("A" & i) = k
                            k = k + 1
                            Else
                          End If
                        Next i
                    End With
            If Reponse = 6 Then clear_dn_1
 
            End If
          
End Sub
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour YANNISE,

J'avais donné des solutions erronées, je les ai supprimées.

Voyez ce fichier (2) et la macro :
VB: 
Sub Transfert()
Dim F1 As Worksheet, F2 As Worksheet, P As Range, Q As Range, n%, lig&, nn%, c As Range
Set F1 = Feuil1
Set F2 = Feuil2
Set P = F1.[E6,G6,I6] 'Ligne 1
Set Q = Union(F1.[E3], F1.[G3], IIf(Application.CountA(P.Offset(6)) = 3, Union(P, P.Offset(3)), P))
If Not Q.Find("", , xlValues) Is Nothing Then
    Q.SpecialCells(xlCellTypeBlanks).Select
    MsgBox "Renseignez la ou les cellule(s) sélectionnée(s)"
    Exit Sub
End If
If F2.FilterMode Then F2.ShowAllData 'si la feuille est filtrée
For n = 0 To 2
    Set Q = P.Offset(3 * n) 'décalage
    If Application.CountA(Q) = 3 Then
        lig = F2.Cells(F2.Rows.Count, 1).End(xlUp).Row + 1
        F2.Cells(lig, 1) = Val(F2.Cells(lig - 1, 1)) + 1
        F2.Cells(lig, 2) = F1.[E3] 'commande
        F2.Cells(lig, 3) = F1.[G3] 'date
        nn = 0
        For Each c In F2.Cells(lig, 4).Resize(, 3)
            nn = nn + 1
            c = Q.Areas(nn)
        Next c
    End If
Next n
F2.Select 'facultatif
End Sub
A+
 

Pièces jointes

  • Classeur(2).xlsm
    24 KB · Affichages: 6
Vote positif 0 Vote négatif
Y

YANNISE

XLDnaute Junior
Bonjour @job75 ,

Je vous remercie pour votre effort c'est très apprécié de votre part

Par contre je veux garder la macro que j’ai déjà, car elle est lié un projet mais elle ne lui manque qu’une petite modification

Si tu vois mon poste #4 il ne me reste qu’une retouche pour arriver au but
 
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Bonsoir job75, YANNISE,

job75 à dit:
Comme je l'ai dit votre code est beaucoup trop compliqué.
Ma macro est simple et facile à adapter si nécessaire.
Cliquez pour agrandir...

moi aussi, j'avais fourni un code beaucoup plus simple à YANNISE ; c'était dans mon post #11 du 19 juin, et il l'avait adoré ! quand j'ai vu son énoncé de ce sujet, je n'ai pas compris pourquoi il avait remis un code vba avec des morceaux compliqués et mal optimisés, mébon, si c'est son choix... 😜​

soan
 
Vote positif 0 Vote négatif
Deadpool_CC

Deadpool_CC

XLDnaute Accro
Bonsoir,
en effet, code indigeste ..; je l'ai pas fini.
si tu veux pas lâcher ton code, juste avant un copie de ligne, teste si le nbval de toute tes cellule = 0 si c'est le cas t'as qu'a faire un exit sub comme cela t'aura tout arrêté car t'a une ligne vide.
 
Vote positif 0 Vote négatif
Y

YANNISE

XLDnaute Junior
Bonjour @job75 @Deadpool_CC @soan ;

job75 à dit:
Comme je l'ai dit votre code est beaucoup trop compliqué, l'étudier m'est insupportable, désolé.

Ma macro est simple et facile à adapter si nécessaire.
Cliquez pour agrandir...
merci @job75 pour votre aide, je vais voir comment je peux le résoudre

soan à dit:
Bonsoir job75, YANNISE,



moi aussi, j'avais fourni un code beaucoup plus simple à YANNISE ; c'était dans mon post #11 du 19 juin, et il l'avait adoré ! quand j'ai vu son énoncé de ce sujet, je n'ai pas compris pourquoi il avait remis un code vba avec des morceaux compliqués et mal optimisés, mébon, si c'est son choix... 😜​

soan
Cliquez pour agrandir...
@soan je tien au code car il me convient parfaitement, sans dévalorisé la votre :)

Deadpool_CC à dit:
Bonsoir,
en effet, code indigeste ..; je l'ai pas fini.
si tu veux pas lâcher ton code, juste avant un copie de ligne, teste si le nbval de toute tes cellule = 0 si c'est le cas t'as qu'a faire un exit sub comme cela t'aura tout arrêté car t'a une ligne vide.
Cliquez pour agrandir...

@Deadpool_CC je vais essayer, merciiiiiiiii

sinon je vais penser à une autre méthode dont vous avez proposées, merci à tous.
 
Vote positif 0 Vote négatif

Discussions similaires

Y
  • Résolu(e)
XL 2016 Transfère des données réparties sur des lignes à une base de données
Réponses
12
Affichages
2 K
soan
S
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
450
GClaire
G
M
  • Question
XL 2013 Envoyer un mail automatique avec le contenu de la bonne ligne
Réponses
2
Affichages
801
Oneida
Oneida
I
  • Résolu(e)
XL 2019 Supprimer une ligne d'une base de données une fois qu'elle est transférée sur une autre feuille
Réponses
8
Affichages
582
Isabellisa
I
S
  • Question
XL 2016 Code de transfert
Réponses
8
Affichages
923
Seddiki_adz
S
Cédric L
  • Question
XL 2019 Récupérer des données et les inscrire jour après jour des premières cellules vides de colonne
2
Réponses
29
Affichages
3 K
Cédric L
Cédric L
Roseline
  • Résolu(e)
Microsoft 365 Modifier une liste sur deux onglets
Réponses
11
Affichages
1 K
Roseline
Roseline
M
  • Question
Microsoft 365 Une barre de données avec des nuances de couleurs
Réponses
1
Affichages
2 K
Rouge
R
G
  • Résolu(e)
XL 2016 Définir Boucle pour afficher plusieurs tableaux dans des textbox sur une userform (ou sur une feuille Excel)
Réponses
6
Affichages
1 K
gaby.jvx
G
N
  • Question
XL 2016 Copier des lignes d'une feuille à l'autre sur une même Excel par double clique
Réponses
0
Affichages
1 K
Ned2
N

Membres actuellement en ligne

16 membres et 99 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 091
Messages
2 116 114
Membres
112 663
dernier inscrit
Pauline243