Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Simplification VBA

julien741

XLDnaute Nouveau
Bonjour,
Je me permet de vous solliciter car j'ai écrit un code en VBA pour transférer les données d'une feuille sur une autre pour crée une base de donnée, mais j'ai trop de données qui fait que cela se fonctionne plus.
Le but est de transférer comme vous pourrez le voir sur le fichier joint les données de la feuille FPE1 à BDD.
J'ai sur la feuille FPE1 des presses n°10,1,.... avec trois lignes par presse (nombre max de changement de produit sur la presse) que j'ai transformé en colonne dans la BDD.
Je souhaite transféré dans la BDD une ligne par presse.

Merci à vous de votre aide.

Cdt.
Julien.
 

Pièces jointes

  • Fiche à remplir entier pour 1jrs V2.xlsm
    339.1 KB · Affichages: 6
Solution
Oups, pas vu.
Il suffit de remplacer la boucle While par un For next :
VB:
Sub TransfertBDD()
    Application.ScreenUpdating = False       ' On fige écran pour aller plus vite
    Dim DL%, L%
    Set F = Sheets("BDD")
    DL = 1 + F.Range("B65500").End(xlUp).Row ' Dernière ligne de BDD
    For L = 11 To 68 Step 3                  ' Pour tout le tableau
        If Cells(L, "B") <> "" Then          ' Tant qu'en B on a une valeur
            F.Cells(DL, "B") = [B8]              ' Date
            F.Cells(DL, "C") = [G6]              ' Equipe
            F.Cells(DL, "D") = [C6]              ' Operateurs
            F.Cells(DL, "F") = [I7]              ' Nbre opérateur
            F.Cells(DL, "E") = Cells(L, "A")     ' Col A
            '...

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour julien,
Un essai en PJ avec cette macro simplifiée :
VB:
Sub TransfertBDD()
    Application.ScreenUpdating = False       ' On fige écran pour aller plus vite
    Set F = Sheets("BDD")
    DL = 1 + F.Range("B65500").End(xlUp).Row ' Dernière ligne de BDD
    L = 11                                   ' Ligne de lecture
    While Cells(L, "B") <> ""                ' Tant qu'en B on a une valeur
        F.Cells(DL, "B") = [B8]              ' Date
        F.Cells(DL, "C") = [G6]              ' Equipe
        F.Cells(DL, "D") = [C6]              ' Operateurs
        F.Cells(DL, "F") = [I7]              ' Nbre opérateur
        F.Cells(DL, "E") = Cells(L, "A")     ' Col A
        ' Transfert des trois lignes
        F.Range("G" & DL & ":V" & DL) = Range("B" & L + 0 & ":Q" & L + 0).Value
        F.Range("W" & DL & ":AL" & DL) = Range("B" & L + 1 & ":Q" & L + 1).Value
        F.Range("AM" & DL & ":BB" & DL) = Range("B" & L + 2 & ":Q" & L + 2).Value
        ' Saut de ligne de lecture de 3, et pointeur d'écriture de 1
        L = L + 3: DL = DL + 1
    Wend
    Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • Fiche à remplir entier pour 1jrs V2.xlsm
    339.1 KB · Affichages: 3

julien741

XLDnaute Nouveau
Bonjour Sylvanu,

Merci de ton retour, la macro marche bien, par contre il faut ajouter une chose, j'ai compléter par exemple la presse 19 en laissant les précédente vide et le transfère de donnée ne se fait plus.
C'est aussi pour cela que j'avais fais 20 fois la copie de transfère de donnée, car il peu arrivé que toute les presse ne fonctionne pas, donc je vais avoir du vide dans certaine ligne (presse).
Penses-tu qu'il est possible de compléter ta formule?

Merci.

Cdt.
Julien.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Oups, pas vu.
Il suffit de remplacer la boucle While par un For next :
VB:
Sub TransfertBDD()
    Application.ScreenUpdating = False       ' On fige écran pour aller plus vite
    Dim DL%, L%
    Set F = Sheets("BDD")
    DL = 1 + F.Range("B65500").End(xlUp).Row ' Dernière ligne de BDD
    For L = 11 To 68 Step 3                  ' Pour tout le tableau
        If Cells(L, "B") <> "" Then          ' Tant qu'en B on a une valeur
            F.Cells(DL, "B") = [B8]              ' Date
            F.Cells(DL, "C") = [G6]              ' Equipe
            F.Cells(DL, "D") = [C6]              ' Operateurs
            F.Cells(DL, "F") = [I7]              ' Nbre opérateur
            F.Cells(DL, "E") = Cells(L, "A")     ' Col A
            ' Transfert des trois lignes
            F.Range("G" & DL & ":V" & DL) = Range("B" & L + 0 & ":Q" & L + 0).Value
            F.Range("W" & DL & ":AL" & DL) = Range("B" & L + 1 & ":Q" & L + 1).Value
            F.Range("AM" & DL & ":BB" & DL) = Range("B" & L + 2 & ":Q" & L + 2).Value
            ' Saut de ligne d'écriture de 1
            DL = DL + 1
        End If
    Next L
    Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • Fiche à remplir entier pour 1jrs V3.xlsm
    343.7 KB · Affichages: 1

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…