Remplissage automatique de tableau entre deux feuilles Excel

Le 27/01/2022 à 11:30

Bonjour,

J'ai une problématique sur un outils que je souhaite mettre en place dans mon entreprise. Voici ce que je souhaite faire:

1) Pour chaque ligne du tableau 1 de la feuille "EXTRACTION GX" (ci-dessous), prendre le nom de tâche ( Tâche court en rouge) et le numéro de devis associé (Devis n° en bleu)

capture d ecran 2022 01 27 111158

2) Les copier

3) Les coller dans le second tableau vierge de la feuille "ACCEPTANCE SHEET 2" (ci-dessous) selon leur emplacement prévus: Work specification pour le nom de tâche en rouge et Quote number pour Devis n° en bleu.

capture d ecran 2022 01 27 111217

4) Incrémenter au fur et a mesure en créant une ligne dans le tableau vierge identique à la précédente et centrer le texte dans les cellules.

5) Si dans la colonne A ( N° Tâche) il y a un 1, un 2 ou un 3. Ne pas copier/coller et passer à la suite.

Par exemple, pour bien comprendre ce que je souhaite:

- Appuyer sur bouton Acceptance Sheet de la feuille 1

- Pour les trois premières lignes on obtient dans le tableau ceci:

capture d ecran 2022 01 27 111328

J'avais commencé quelque chose mais ça bloque:

Sub AccS()

Sheets("ACCEPTANCE SHEET 2").Rows("11:" & Sheets("ACCEPTANCE SHEET 2").Range("B" & Rows.Count).Row).Clear
Sheets("ACCEPTANCE SHEET 2").Range("A10") = ""
Sheets("ACCEPTANCE SHEET 2").Range("B10") = ""
ligne = Sheets("ACCEPTANCE SHEET 2").Range("B" & Rows.Count).End(xlUp).Row
i = 2
Do While i < Sheets("EXTRACTION GX").Range("B" & Rows.Count).End(xlUp).Row + 1
If ligne > 19 Then

If Sheets("EXTRACTION GX").Cells(i, 1).Value = 1 Or Sheets("EXTRACTION GX").Cells(i, 1).Value = 2 Or Sheets("EXTRACTION GX").Cells(i, 1).Value = 3 Then
i = i + 1

End If

Sheets("ACCEPTANCE SHEET 2").Range("B" & ligne & ":B" & ligne).EntireRow.Copy Sheets("ACCEPTANCE SHEET 2").Range("B" & ligne + 1).EntireRow
Sheets("ACCEPTANCE SHEET 2").Range("B" & ligne + 1 & ":B" & ligne + 1).ClearContents
End If
Sheets("ACCEPTANCE SHEET 2").Range("B" & ligne + 1).Value = Sheets("EXTRACTION GX").Range("B" & i).Value
If Sheets("EXTRACTION GX").Range("D" & i) <> "" Then
Sheets("ACCEPTANCE SHEET 2").Range("A" & ligne + 1).Value = Sheets("EXTRACTION GX").Range("D" & i).Value
Else
Sheets("ACCEPTANCE SHEET 2").Range("A" & ligne + 1).Value = "-"
End If

Sheets("ACCEPTANCE SHEET").Activate
With Sheets("ACCEPTANCE SHEET 2").Range("A1:A10000")
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With

With Sheets("ACCEPTANCE SHEET 2").Range("B16:B10000")
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
Sheets("EXTRACTION GX").Activate

End Sub

Vous trouverez également mon fichier avec le code VBA.

Merci par avance pour votre aide,

16outils-test.xlsm (62.33 Ko)
Le 27/01/2022 à 18:17

Bonsoir ponchorabane, le forum,

Je ne vois pas l'utilité des cases à cocher...si c'est validé, on rentre une date, non ?

J'ai également viré les cellules fusionnées.

Une façon de procéder : ( macro associée au bouton 'Acceptance Sheet')

Sub AcceptanceS()
 Dim tb, tbR(), i%, k%, derlig%, lig%
  Application.ScreenUpdating = False

  With Sheets("EXTRACTION GX")
   tb = .Range("A2:E" & .Range("A" & Rows.Count).End(xlUp).Row)
     k = 0
    For i = 1 To UBound(tb, 1)
     If tb(i, 4) <> "" Then
      ReDim Preserve tbR(1 To 4, 1 To k + 1)
       tbR(1, 1 + k) = tb(i, 4)
       tbR(2, 1 + k) = tb(i, 2)
       tbR(3, 1 + k) = "Date : …................."
       tbR(4, 1 + k) = "Date : …................."
       k = 1 + k
     End If
    Next i
    On Error Resume Next
     With Sheets("ACCEPTANCE SHEET 2")
      lig = .Range("A" & Rows.Count).End(xlUp).Row + 1
      .Range("A" & lig).Resize(UBound(tbR, 2), 4) = Application.Transpose(tbR)
       derlig = .Range("A" & Rows.Count).End(xlUp).Row
      .Rows("9:" & derlig).RowHeight = 62.25
      .Rows("9:" & derlig).HorizontalAlignment = xlCenter
      .Rows("9:" & derlig).VerticalAlignment = xlCenter
      .Range("A9:G" & derlig).Borders.LineStyle = xlContinuous
      .Activate
     End With
  End With
  Erase tb: Erase tbR
End Sub
8ponchorabane.xlsm (56.24 Ko)

Cordialement,

Le 28/01/2022 à 10:24

Bonjour xorsankukai,

Tout d'abord merci pour ton aide rapide et efficace cela fonctionne très bien.

Je me suis juste rendu compte d'une chose, c'est que je voudrais que le tableau de la feuille ACCEPTANCE SHEET 2 prennent également les nom de tâche de la feuille EXTRACTION GX même si Devis n° (colonne 4) est vide et que les valeurs dans N°tâche (colonne 1) soient différentes de 1,2 ou 3.

Pensez vous que cela soit envisageable ?

Merci et bonne journée,

Le 28/01/2022 à 10:49

Bonjour et merci pour ce retour,

je voudrais que le tableau de la feuille ACCEPTANCE SHEET 2 prennent également les nom de tâche de la feuille EXTRACTION GX même si Devis n° (colonne 4) est vide et que les valeurs dans N°tâche (colonne 1) soient différentes de 1,2 ou 3.

Autrement dit, si la valeur de la colonne A est >3 ?

'...............DEBUT SUB ACCEPTANCE SHEET 2 ................................
Sub AcceptanceS()
 Dim tb, tbR(), i%, k%, derlig%, lig%, dl%
  Application.ScreenUpdating = False

  With Sheets("EXTRACTION GX")
       dl = .Range("A" & Rows.Count).End(xlUp).Row
    If dl = 1 Then Exit Sub
   tb = .Range("A2:E" & dl)
     k = 0
    For i = 1 To UBound(tb, 1)
     If tb(i, 1) > 3 And IsNumeric(tb(i, 1)) Then
      ReDim Preserve tbR(1 To 4, 1 To k + 1)
       tbR(1, 1 + k) = tb(i, 4)
       tbR(2, 1 + k) = tb(i, 2)
       tbR(3, 1 + k) = "Date : …................."
       tbR(4, 1 + k) = "Date : …................."
       k = 1 + k
     End If
    Next i
    On Error Resume Next
     With Sheets("ACCEPTANCE SHEET 2")
      lig = .Range("A" & Rows.Count).End(xlUp).Row + 1
      .Range("A" & lig).Resize(UBound(tbR, 2), 4) = Application.Transpose(tbR)
       derlig = .Range("B" & Rows.Count).End(xlUp).Row
      .Rows(lig & ":" & derlig).RowHeight = 62.25
      .Rows(lig & ":" & derlig).HorizontalAlignment = xlCenter
      .Rows(lig & ":" & derlig).VerticalAlignment = xlCenter
      .Range("A" & lig & ":G" & derlig).Borders.LineStyle = xlContinuous
      .Activate
     End With
  End With
  Erase tb: Erase tbR
End Sub
'...............FIN SUB ACCEPTANCE SHEET................................

Cordialement,

Le 28/01/2022 à 11:04

Alors le but de ce bouton est que pour chaque n°devis présent dans la colonne 4 de la feuille EXTRACTION GX, il copie le nom de tâche (Tâche court) et le numéros de devis (Devis n°) pour chaque ligne et les colle dans les colonnes 1 et 2 du tableau de ACCEPTANCE SHEET 2.

Cependant, parfois il n'y a pas de n°devis dans la colonne et je souhaiterait qu'il copie quand même les noms de tâche associés avec pour conditions que la valeur pour ce même nom dans la colonne 1 (N°Tâche) soit différente de 1, 2 ou 3.

Pour expliquer, s'il y a cette valeur dans la colonne 1 c'est que le nom de tâche a un statut particulier mais cela n'entre pas dans le sujet.

Par exemple, dans le fichier que je vous ai envoyé, il devrait y avoir dans le tableau de la feuille ACCEPTANCE SHEET 2 après avoir appuyé sur le bouton:

QUOTE NUMBER WORKS SPECIFICATION

Devis n°1 UNSTEPPING

Devis n°3 HAULING

Devis n°24 Bonbords

etc.

C'est peut-être plus clair pour vous ?

D'ailleurs est-il possible dans la colonne 1 de ACCEPTANCE SHEET de ne pas mettre "DEVIS N°" avant chaque numéros dans les cellules ?

Merci en tout cas

Le 28/01/2022 à 11:49

Re,

D'ailleurs est-il possible dans la colonne 1 de ACCEPTANCE SHEET de ne pas mettre "DEVIS N°" avant chaque numéros dans les cellules ?

A tester....

'...............DEBUT SUB ACCEPTANCE SHEET 2 ................................
Sub AcceptanceS()
 Dim tb, tbR(), i%, k%, derlig%, lig%, dl%
  Application.ScreenUpdating = False

  With Sheets("EXTRACTION GX")
       dl = .Range("A" & Rows.Count).End(xlUp).Row
    If dl = 1 Then Exit Sub
   tb = .Range("A2:E" & dl)
     k = 0
    For i = 1 To UBound(tb, 1)
     If tb(i, 1) > 3 And IsNumeric(tb(i, 1)) Then
      ReDim Preserve tbR(1 To 4, 1 To k + 1)
       tbR(1, 1 + k) = Mid(tb(i, 4), 9)
       tbR(2, 1 + k) = tb(i, 2)
       tbR(3, 1 + k) = "Date : …................."
       tbR(4, 1 + k) = "Date : …................."
       k = 1 + k
     End If
    Next i
    On Error Resume Next
     With Sheets("ACCEPTANCE SHEET 2")
      lig = .Range("A" & Rows.Count).End(xlUp).Row + 1
      .Range("A" & lig).Resize(UBound(tbR, 2), 4) = Application.Transpose(tbR)
       derlig = .Range("B" & Rows.Count).End(xlUp).Row
      .Rows(lig & ":" & derlig).RowHeight = 62.25
      .Rows(lig & ":" & derlig).HorizontalAlignment = xlCenter
      .Rows(lig & ":" & derlig).VerticalAlignment = xlCenter
      .Range("A" & lig & ":G" & derlig).Borders.LineStyle = xlContinuous
      .Activate
     End With
  End With
  Erase tb: Erase tbR
End Sub
'...............FIN SUB ACCEPTANCE SHEET................................

Cordialement,

Le 28/01/2022 à 14:04

J'ai essayé et ça marche nickel !

Part contre, j'ai essayé sur un plus gros tableau avec plus de donnée et la première tâche n'apparait pas dans mon tableau de ACCEPTANCE SHEET.

capture d ecran 2022 01 28 140202 capture d ecran 2022 01 28 140151

La première ligne ne correspond pas à celle du tableau de EXTRACTION GX.

De plus, serait il possible de remettre les cases à cocher supprimées et de les incrémenter à chaque ligne lorsqu'on génère le tableau s'il vous plait ?

Vous m'aidez grandement en tout cas

Cordialement

Le 28/01/2022 à 14:59

Re,

J'ai eu le même souci avec ton fichier de départ, la fusion entre les lignes 8 et 9 fausse la définition de la première ligne vide.

lig = .Range("A" & Rows.Count).End(xlUp).Row + 1

Excel doit interpréter la première ligne vide comme étant la 9....

Tu me diras qu'il suffit de mettre + 2 : effectivement, mais si tu rajoutes des lignes par la suite, on aura 1 ligne vide à chaque fois.

J'ai donc fait au plus simple, et comme il est fortement déconseillé de fusionner des cellules....car source de problème...j'ai préféré la virer, .

Crdlt,

Le 28/01/2022 à 15:12

Re,

On peut ruser ....

J'ai écrit un texte en D9 (j'ai changé la couleur de la police pour qu'il n'apparaisse pas).

On peut alors définir :

 lig = .Range("D" & Rows.Count).End(xlUp).Row + 1
4ponchorabane-v2.xlsm (58.03 Ko)

Crdlt,

Le 28/01/2022 à 15:32

Re,

Merci pour ton retour. Malheureusement, cela ne fonctionne toujours pas

Je n'ai toujours pas la première ligne de mon tableau de la feuille EXTRACTION GX à la première de mon tableau de la feuille ACCEPTANCE SHEET..

Cordialement

Le 28/01/2022 à 15:44

Voici un fichier avec plus de données et le code ajouté.

Comment peut on faire pour refaire apparaitre les case à cocher ?

Merci

4outils-projet-pm-test-28-01-2022v4.xlsm (129.73 Ko)
Le 28/01/2022 à 16:22

Re,

Je n'ai toujours pas la première ligne de mon tableau de la feuille EXTRACTION GX à la première de mon tableau de la feuille ACCEPTANCE SHEET..

Ça ne fonctionne pas car tu n'as pas de texte en D9....

Comment peut on faire pour refaire apparaitre les case à cocher ?

Désolé, je ne maitrise pas ces cases à cocher....

Ceci dit, on peut ruser, à supposer qu'on aura toujours la première ligne avec les cases à cocher, il suffit alors de les "tirer" jusqu'à le dernière ligne...

Cela implique que si tu supprimes les données de ton tableau, il faudra conserver C10:D10 et F10:G10....

7ponchorabane-v3.xlsm (77.92 Ko)

Crdlt,

Le 28/01/2022 à 17:04

Parfait ça fonctionne merci beaucoup !!!

Le 02/02/2022 à 15:32

Bonjour,

Une nouvelle problématique est apparue sur le sujet. J'ai fusionné les lignes aux colonnes D8 D9 et E8 E9 et évidemment, le programme ne fonctionne plus très bien.

capture d ecran 2022 02 02 153224

Est il possible d'ajouter une variante au code pour pouvoir résoudre ce soucis s'il vous plait ?

Sinon dans l'ensemble c'est parfait tout fonctionne parfaitement.

Merci par avance,

Cordialement,

4ponchorabane-v3.xlsm (77.92 Ko)
Le 02/02/2022 à 16:10

Bonjour,

La fusion des lignes 8 et 9 est inutile, il suffit d'augmenter la hauteur de la ligne pour obtenir le même rendu.

5ponchorabane-v4.xlsm (77.81 Ko)

Cordialement,

Rechercher des sujets similaires à "remplissage automatique tableau entre deux feuilles"