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

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

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:

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.
 

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
 

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

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
 

soan

XLDnaute Barbatruc
Inactif
Bonsoir job75, YANNISE,

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

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
 

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.
 

YANNISE

XLDnaute Junior
Bonjour @job75 @Deadpool_CC @soan ;

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.
merci @job75 pour votre aide, je vais voir comment je peux le résoudre

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
@soan je tien au code car il me convient parfaitement, sans dévalorisé la votre :)

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.

@Deadpool_CC je vais essayer, merciiiiiiiii

sinon je vais penser à une autre méthode dont vous avez proposées, merci à tous.
 

Discussions similaires

Statistiques des forums

Discussions
311 716
Messages
2 081 828
Membres
101 823
dernier inscrit
mohamed3s