XL 2016 Simplification VBA

julien741 · 21 Décembre 2021

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.

sylvanu · 21 Décembre 2021

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 · 21 Décembre 2021

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

julien741 · 21 Décembre 2021

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 · 21 Décembre 2021

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

julien741 · 21 Décembre 2021

C'est super Merci pour ton aide, ca m'aide beaucoup. je t'offre malheureusement un jolie cocktail en virtuel au lieu d'un vrai
et passe de bonne fêtes.

sylvanu · 21 Décembre 2021

Pour les lecteurs futurs, mettez la solution en vert, pas votre propre message.

julien741 · 21 Décembre 2021

Oups navré , je pensais que c'était le dernier message.

sylvanu · 21 Décembre 2021

Non, le vert permet aisément au futur lecteur de trouver la solution.
C'est très utile sur les post qui peuvent avoir une dizaines de fichiers joint. La bonne solution n'étant pas toujours la dernière.

XL 2016 Simplification VBA

julien741

XLDnaute Nouveau

Pièces jointes

sylvanu

sylvanu

XLDnaute Barbatruc

Pièces jointes

julien741

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

julien741

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

julien741

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Discussions similaires