Copier et contrôler plusieurs lignes d'un tableau avec un seul Macro VBA

Question

Je fais recours à votre aide afin de trouver une solution pour ma macro qui n'ait pas parfait j'ai une sorte de tableau que les utilisateurs doivent le remplir et enregistrer dans une base de données, et pour cela j'ai essayé de faire une macro mais ce n’est pas bouclé au point que je veux Car ledit tableau se compose de plieuses lignes et pour chaque commande elle peut avoir une seule ligne ou plusieurs alors je veux que la macro copier les informations depuis la feuil1 a la feuil2 quel que soit le nombre de ligne sur le tableau Si la première ligne est seulement remplie alors les informations passent à la BD correctement Mais si la première ligne est remplie et sur l'un des lignes une cellule renseignée et les autres non, alors une alerte ce d'éclanche avec le MsgBox Ainsi la macro doit attribue une seule numérotation automatique « numéro de la pièce commande » que pour chaque commande enregistrer sur BD Ci-après le code ainsi que le fichier Excel ci joint Merci d'avance pour l'aide. Sub Enregistrer_Données() Dim Reponse As Byte Dim PL As Range, Cel As Range, Lettre$, Message$ Dim Mavariable As String Set PL = Feuil1.Range("C2,F2,B7,C7,D7,E7,F7,B10,C10,D10,E10,F10,B13,C13,D13,E13,F13,B16,C16,D16,E16,F16") For Each Cel In PL Select Case Cel.Address(False, False, xlA1) Case "C2": Lettre = "'TP'" Case "F2": Lettre = "'RE'" Case "B7": Lettre = "'Référence'" Case "C7": Lettre = "'Article'" Case "D7": Lettre = "'Poste" Case "E7": Lettre = "'Quantité'" Case "F7": Lettre = "'Désignation'" Case "B10": Lettre = "'Référence'" Case "C10": Lettre = "'Article'" Case "D10": Lettre = "'Poste" Case "E10": Lettre = "'Quantité'" Case "F10": Lettre = "'Désignation'" Case "B13": Lettre = "'Référence'" Case "C13": Lettre = "'Article'" Case "D13": Lettre = "'Poste" Case "E13": Lettre = "'Quantité'" Case "F13": Lettre = "'Désignation'" Case "B16": Lettre = "'Référence'" Case "C16": Lettre = "'Article'" Case "D16": Lettre = "'Poste" Case "E16": Lettre = "'Quantité'" Case "F16": Lettre = "'Désignation'" 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 End Select Next Cel If Message &lt;&gt; "" Then MsgBox Message & vbLf & vbLf & vbLf & "Veuillez saisir le champ signalé (s) ", vbCritical + vbOKOnly, "Erreur de saisie" Else Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C2") Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F2") Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B7") Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C7") Feuil2.Range("G9999").End(xlUp).Offset(1, 0) = Feuil1.Range("D7") Feuil2.Range("H9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E7") Feuil2.Range("I9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F7") Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C2") Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F2") Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B10") Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C10") Feuil2.Range("G9999").End(xlUp).Offset(1, 0) = Feuil1.Range("D10") Feuil2.Range("H9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E10") Feuil2.Range("I9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F10") Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C2") Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F2") Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B13") Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C13") Feuil2.Range("G9999").End(xlUp).Offset(1, 0) = Feuil1.Range("D13") Feuil2.Range("H9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E13") Feuil2.Range("I9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F13") Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C2") Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F2") Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B16") Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("C16") Feuil2.Range("G9999").End(xlUp).Offset(1, 0) = Feuil1.Range("D16") Feuil2.Range("H9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E16") Feuil2.Range("I9999").End(xlUp).Offset(1, 0) = Feuil1.Range("F16") 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 = 1111 For i = 3 To .Range("C" & .Rows.Count).End(xlUp).Row If IsNumeric(.Range("B" & i)) And .Range("C" & i) &lt;&gt; "" Then .Range("B" & i) = k k = k + 1 Else End If Next i End With If Reponse = 6 Then clear_dn_1 End If End Sub...

yal_excel · Answer

Une proposition qui apporte un certain nombre de changements dans ton classeur qui m'a semblé peu fonctionnel. J'ai introduit un contrôle quand on saisi une Commande Référence. Si cette référence existe déjà en feuille 2 les données sont chargées dans le tableau de la feuille 1...

ThauThème · Answer

Bonjour le fil, bonjour le forum,

J'ai repris la présentation de Yal car elle est beaucoup plus facile à coder. En pièce jointe ton fichier modifié avec le code ci-dessous :

Option Explicit
Private O1 As Worksheet 'déclare la variable O1 (Onglet 1)
Private O2 As Worksheet 'déclare la variable O2 (Onglet 2)
Private T1 As ListObject 'déclare la variable T1 (Tableau structuré 1)
Private T2 As ListObject 'déclare la variable T2 (Tableau structuré 2)

Sub TransfertCommande()
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim R As Range 'déclare la variable R (Recherche)
Dim LI As Integer 'déclare la variable LI (LIgne)

Set O1 = Worksheets("Feuil1") 'définit l'onglet O1
Set O2 = Worksheets("Feuil2") 'définit l'onglet O2
Set T1 = O1.ListObjects(1) 'définit le tableau structuré T1
Set T2 = O2.ListObjects(1) 'définit le tableau structuré T2

'oblige à renseigner C2
With Range("C2") 'prend en compte la cellule C2
    If .Value = "" Then 'condition : si vide
        .Select 'sélectionne
        MsgBox "Vous devez renseigner la référence de la commande !" 'message
        Exit Sub 'sort de la procédure
    End If 'fin de la condition
End With 'fin de la prise en compte de la cellule C2

'oblige à renseigner F2
With Range("F2") 'prend en compte la cellule F2
    If .Value = "" Then 'condition : si vide
        .Select 'sélectionne
        MsgBox "Vous devez renseigner la date !" 'message
        Exit Sub 'sort de la procédure
    End If 'fin de la condition
End With 'fin de la prise en compte de la cellule C2

'oblige à renseigner toutes les cellules d'une ligne
For I = 1 To T1.ListRows.Count 'boucle 1 : sur toutes les lignes I de T1
    For J = 1 To T1.ListColumns.Count 'boucle 2 sur toutes les colonnes J de T1
        If T1.DataBodyRange(I, J) = "" Then 'si la donnée ligne I colonne J de T1 est vide
            T1.DataBodyRange(I, J).Select 'sélectionne
            MsgBox "Vous devez renseigner cette cellule !" 'message
            Exit Sub 'sort de la procédure
        End If 'fin de la condition
    Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1

NL = T1.ListRows.Count 'définit le nombre de ligne NL de T1
For I = 1 To NL 'boucle de 1 à NL
    Set R = T2.ListColumns(1).Range.Find("") 'définit la recherche R (recherche du vide dans la colonne 1 de T2)
    If R Is Nothing Or T2.ListRows.Count = 0 Then 'condition : si il n'existe aucune occurrence ou si T2 ne contient aucune ligne
        T2.ListRows.Add 'ajoute uhne ligne à T2
        LI = T2.ListRows.Count 'définit la ligne LI (le nombre de ligne de T2)
    Else 'sinon (au moins une occurrence trouvée)
        LI = R.Row - T2.HeaderRowRange.Row 'définit la ligne Li (ligne de la première occurrence trouvé moins la ligne de en-tête de T2)
    End If 'fin de la condition
    'renvoie le numéro automatique incrémenté dans la ligne LI, colonne 1 de T2
    T2.DataBodyRange(LI, 1) = Application.WorksheetFunction.Max(T2.DataBodyRange.Columns(1)) + 1
    T2.DataBodyRange(LI, 2) = O1.Range("C2").Value 'renvoie la "Commande Référence" dans la ligne LI, colonne 2 de T2
    T2.DataBodyRange(LI, 3) = O1.Range("F2").Value 'renvoie la date dans la ligne LI, colonne 3 de T2
    T2.DataBodyRange(LI, 4).Resize(1, 5).Value = T1.ListRows(I).Range.Value 'renvoie les données de T1 dans la cellule ligne LI colonne 4 redimensionnée de T2
Next I 'prochaine ligne de la boucle
End Sub

Sub Nettoie()
Set O1 = Worksheets("Feuil1") 'définit l'onglet O1
Set T1 = O1.ListObjects(1) 'définit le tableau structuré T1
If T1.ListRows.Count > 0 Then T1.DataBodyRange.Delete 'efface les données de T1 si T1 contient au moins un ligne
O1.Range("C2", "F2").ClearContents 'efface C2 et F2
O1.Range("C2").Select 'sélectionne F2
End Sub

Le fichier :

10niba-ep-v01.xlsm (24.27 Ko)