Microsoft 365 duree macro trop longue

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion eric72
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
E

eric72

XLDnaute Accro
Bonjour à tous,
Je profite de ce post pour vous souhaiter une belle année 2025
Je me tourne vers votre savoir afin de, peut-être, réduire le temps d'exécution d'une macro (macro sur un tableau qui peut atteindre 2000 lignes et 139 colonnes), en effet lorsque tout est rempli cela peut atteindre près de 30 secondes, mais il y a surement mieux à faire!!!
Merci beaucoup pour votre aide
Eric
 
Solution
vgendron
avec CE code
si la table maj est VIDE (meme pas une ligne==> tu as donc fait un delete sur TOUTES les lignes de la table ==> ca fonctionne bien
si la table maj contient déjà toutes les lignes, = les nouvelles lignes sont bien ajoutées
si la table maj contient AU MOINS 2 lignes ==> idem
si la table Maj ne contient qu'UNE seule ligne ==> apparition des 138 ref ==> c'est à cause de la fonction transpose qui ne SAIT pas transposer une seule ligne en une seule colonne ==> solution s'assurer d'avoir toujours au moins 2 lignes ( elles peuvent etre vide)
VB: 
Sub Transferer()
Dim i As Integer
Dim j As Integer
Dim Ind As Integer
Dim NbLig As Integer
Dim Trouvé As Boolean
Dim LigDest As Integer
Dim RefDev As String
Dim TSCommande As ListObject
Dim...
Trier par date Trier par votes
vgendron à dit:
et pour éviter la recopie de la ligne d'entete (à chaque fois que tu relances la macro..) il faut corriger avec ceci

VB: 
 With TSMaj
        .Range(1, 1).Resize(UBound(TabMaj, 2), UBound(TabMaj, 1)) = Application.WorksheetFunction.Transpose(TabMaj)
    End With
Cliquez pour agrandir...
Waouhhhh c'est génial,
et si je souhaite copier une autre plage de colonnes exemple de la 13ème à la 16ème, ou dois je ajouter le code (je ne suis pas très ferré en tablo, lol)?
 
Vote positif 0 Vote négatif
vgendron à dit:
et pour éviter la recopie de la ligne d'entete (à chaque fois que tu relances la macro..) il faut corriger avec ceci

VB: 
 With TSMaj
        .Range(1, 1).Resize(UBound(TabMaj, 2), UBound(TabMaj, 1)) = Application.WorksheetFunction.Transpose(TabMaj)
    End With
Cliquez pour agrandir...
Je me permets de mettre le code de mon fichier d'origine pour comprendre les differentes plages de colonnes que je dois transférer:
VB: 
Sub Copier_Valeurs()

 

Dim LigneSource As Long, LigneCible As Long
Dim MaValeur As String
Dim MaPlageDeRecherche As Range, MaCelluleTrouvee As Range

    ' On empêche la mise à jour de l'affichage
    Application.ScreenUpdating = False
'Stop
    ' Pour chaque ligne de données du tableau source
    For LigneSource = 1 To Range("TbCommande").ListObject.ListRows.Count

        ' Affectation de la valeur à rechercher (colonne "Référence Devis", ligne de n° "LigneSource" du tableau source) à la variable MaValeur
        MaValeur = Range("TbCommande[Référence Devis]")(LigneSource).Value
        ' Affectation de toute la colonne de données "Référence Devis" du tableau source à la variable MaPlageDeRecherche
        Set MaPlageDeRecherche = Range("TbMAJ[Référence Devis]")
        ' Recherche de MaValeur dans la colonne "Référence Devis" du tableau cible
        ' Si la valeur est trouvée, affectation à la variable MaCelluleTrouvee de la cellule trouvée de la feuille
        ' si la valeur n'est pas trouvée, la variable MaCelluleTrouvee est égale à Nothing
        Set MaCelluleTrouvee = MaPlageDeRecherche.Find(What:=MaValeur, LookIn:=xlValues, LookAt:=xlWhole)

        If MaCelluleTrouvee Is Nothing Then
            ' Si valeur non trouvée dans le tableau cible, ajout d'une ligne en fin de tableau cible
            Range("TbMAJ").ListObject.ListRows.Add
            ' Détermination du n° de la nouvelle ligne du tableau cible
            LigneCible = Range("TbMAJ").ListObject.ListRows.Count
        Else
            ' Détermination du n° de ligne dans tableau, de la cellule trouvée
            LigneCible = MaCelluleTrouvee.row - Range("TbMAJ[#headers]").row
        End If

        ' Recopie du premier groupe de données vers le tableau cible
        Range("TbMAJ[[Référence Devis]:[Conf. Comm. Client]]").Rows(LigneCible).Value = Range("TbCommande[[Référence Devis]:[Conf. Comm. Client]]").Rows(LigneSource).Value
        Range("TbMAJ[[Métrage OUI]:[Commande passée au Fournisseur]]").Rows(LigneCible).Value = Range("TbCommande[[Métrage OUI]:[Commande passée au Fournisseur]]").Rows(LigneSource).Value

        '[Commande passée au Fournisseur]
        ' Recopie du deuxième groupe de données vers le tableau cible
        Range("TbMAJ[[Initiales Commercial]:[Initiales Produit9]]").Rows(LigneCible).Value = Range("TbCommande[[Initiales Commercial]:[Initiales Produit9]]").Rows(LigneSource).Value
        ' Recopie du 3ème groupe de données vers le tableau cible
        Range("TbMAJ[[Toury Fermetures]:[Prospect]]").Rows(LigneCible).Value = Range("TbCommande[[Toury Fermetures]:[Prospect]]").Rows(LigneSource).Value
        ' Recopie du 4ème groupe de données vers le tableau cible
        Range("TbMAJ[[DATE MODIFICATION]:[Init]]").Rows(LigneCible).Value = Range("TbCommande[[DATE MODIFICATION]:[Init]]").Rows(LigneSource).Value

    ' Ligne du tableau source suivante
    Next LigneSource
 
End Sub

Merci beaucoup, la vitesse est impréssionnante...
 
Vote positif 0 Vote négatif
je te remets mon code avec des commentaires
VB: 
Sub Transferer()
Dim i As Integer
Dim j As Integer
Dim Ind As Integer
Dim NbLig As Integer
Dim Trouvé As Boolean
Dim LigDest As Integer
Dim RefDev As String
Dim TSCommande As ListObject
Dim TSMaj As ListObject
Dim TabCommande() As Variant
Dim TabMaj() As Variant
Dim start As Single
start = Timer

    'Définition des Tables structurées
    Set TSCommande = Sheets("Commande").ListObjects("TbCommande")
    Set TSMaj = Sheets("MAJ").ListObjects("TbMaj")
    
    With TSCommande 'avec la TS "TbCommande"
        TabCommande = .ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    With TSMaj 'avec la TS "TbMaj"
        TabMaj = Application.WorksheetFunction.Transpose(.ListColumns(1).DataBodyRange.Resize(, 10).Value) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    
    NbLig = 0 'initialisation
    For i = LBound(TabCommande, 1) To UBound(TabCommande, 1) 'pour chaque ligne du tablo
        RefDev = TabCommande(i, 1) 'on récupère la Ref dans la colonne 1
        Trouvé = False 'initialisation
        For Ind = LBound(TabMaj, 2) To UBound(TabMaj, 2)  'on cherche si la référence est déjà dans le tablo TabMaj
            If TabMaj(1, Ind) = RefDev Then 'on la trouve
                LigDest = Ind 'on note la ligne
                Trouvé = True 'on met à vrai
                Exit For 'on sort de la boucle
            End If
        Next Ind
        If Not Trouvé Then 'si pas trouvé (on a donc parcouru TOUT le tablo
            NbLig = NbLig + 1 'on ajoute une ligne
            ReDim Preserve TabMaj(1 To 10, 1 To NbLig) 'on dimensionne le tablo TabMaj
            LigDest = NbLig 'on note la ligne
        End If
        For j = 1 To 10 'on remplit les infos
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
    Next i
    
    With TSMaj 'avec la table
        .DataBodyRange(1, 1).Resize(UBound(TabMaj, 2), UBound(TabMaj, 1)) = Application.WorksheetFunction.Transpose(TabMaj) 'on bascule le résultat
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
End Sub

à noter que pour un redim preserve d'un tablo, on ne peut redimensionner QUE la seconde dimension==>
comme on souhaite ajouter des lignes (avec 1 nombre constant de colonnes)
on est donc obligé d'utiliser un tablo transposé pour inverser ligne et colonne
==> on peut donc ajouter autant de colonnes que l'on souhaite.. et au final on retranspose le tablo..
 
Vote positif 0 Vote négatif
vgendron à dit:
je te remets mon code avec des commentaires
VB: 
Sub Transferer()
Dim i As Integer
Dim j As Integer
Dim Ind As Integer
Dim NbLig As Integer
Dim Trouvé As Boolean
Dim LigDest As Integer
Dim RefDev As String
Dim TSCommande As ListObject
Dim TSMaj As ListObject
Dim TabCommande() As Variant
Dim TabMaj() As Variant
Dim start As Single
start = Timer

    'Définition des Tables structurées
    Set TSCommande = Sheets("Commande").ListObjects("TbCommande")
    Set TSMaj = Sheets("MAJ").ListObjects("TbMaj")
   
    With TSCommande 'avec la TS "TbCommande"
        TabCommande = .ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    With TSMaj 'avec la TS "TbMaj"
        TabMaj = Application.WorksheetFunction.Transpose(.ListColumns(1).DataBodyRange.Resize(, 10).Value) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
   
    NbLig = 0 'initialisation
    For i = LBound(TabCommande, 1) To UBound(TabCommande, 1) 'pour chaque ligne du tablo
        RefDev = TabCommande(i, 1) 'on récupère la Ref dans la colonne 1
        Trouvé = False 'initialisation
        For Ind = LBound(TabMaj, 2) To UBound(TabMaj, 2)  'on cherche si la référence est déjà dans le tablo TabMaj
            If TabMaj(1, Ind) = RefDev Then 'on la trouve
                LigDest = Ind 'on note la ligne
                Trouvé = True 'on met à vrai
                Exit For 'on sort de la boucle
            End If
        Next Ind
        If Not Trouvé Then 'si pas trouvé (on a donc parcouru TOUT le tablo
            NbLig = NbLig + 1 'on ajoute une ligne
            ReDim Preserve TabMaj(1 To 10, 1 To NbLig) 'on dimensionne le tablo TabMaj
            LigDest = NbLig 'on note la ligne
        End If
        For j = 1 To 10 'on remplit les infos
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
    Next i
   
    With TSMaj 'avec la table
        .DataBodyRange(1, 1).Resize(UBound(TabMaj, 2), UBound(TabMaj, 1)) = Application.WorksheetFunction.Transpose(TabMaj) 'on bascule le résultat
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
End Sub

à noter que pour un redim preserve d'un tablo, on ne peut redimensionner QUE la seconde dimension==>
comme on souhaite ajouter des lignes (avec 1 nombre constant de colonnes)
on est donc obligé d'utiliser un tablo transposé pour inverser ligne et colonne
==> on peut donc ajouter autant de colonnes que l'on souhaite.. et au final on retranspose le tablo..
Cliquez pour agrandir...
Le code fonctionne à merveille, pour le nombre de colonnes, je ne comprends pas bien (désolé mais je suis un peu vieux)
Dans l'exemple on copie les données de la colonne A à J, et j'aimerais transférer également de la colonne P à R, puis de AP à AV et tout cela en gardant les données des colonnes non concernées, intactes mais ça n'est peut-être pas possible avec cette méthode à moins d'ajouter un autre tablo dans une autre macro pour les colonnes de P à R etc... et de les appeler l'une après l'autre?
Merci beaucoup pour ton aide
 
Vote positif 0 Vote négatif
eric72 à dit:
Le code fonctionne à merveille, pour le nombre de colonnes, je ne comprends pas bien (désolé mais je suis un peu vieux)
Dans l'exemple on copie les données de la colonne A à J, et j'aimerais transférer également de la colonne P à R, puis de AP à AV et tout cela en gardant les données des colonnes non concernées, intactes mais ça n'est peut-être pas possible avec cette méthode à moins d'ajouter un autre tablo dans une autre macro pour les colonnes de P à R etc... et de les appeler l'une après l'autre?
Merci beaucoup pour ton aide
Cliquez pour agrandir...
j'ai oublié de préciser
Dans l'exemple on copie les données de la colonne A à J, et j'aimerais transférer également de la colonne P à R, puis de AP à AV et tout cela en gardant les données des colonnes non concernées dans TbMAJ, intactes
 
Vote positif 0 Vote négatif
Effectivement, UNE solution serait de créer 3 tableaux qui contiennent chacun les séries de colonnes.. mais bof.. j'ai sans doute mieux..
on met TOUT dans UN tableau
et on extrait les parties souhaitées..
je regarde

pour l'exercice, tu peux t'amuser à faire la première méthode (1 tableau par partie==>3 tableaux)
il te suffit
1) créer les tableaux en prenant soin de modifier les indices de la première colonne et du nombre de colonnes
.listcolumns(1).databodyrange.resize(,10) ===> (1 ==> 1ere colonne = Colonne A) / Resize(,10) == 10= nombre de colonnes (A à J)
2) DANS la boucle existante (for i=1 to 10) tu ajoutes le remplissage des nouveaux tableaux
3) tu ajoutes les lignes de code pour coller les résultats
 
Vote positif 0 Vote négatif
eric72 à dit:
Bonjour,
En effet c'est ce que j'ai fait et cela fonctionne terrible, il ne me reste plus qu'à intégrer le transfert d'autre colonnes comme par exemple de la 14ème colonne à la 18ème mais je ne sais pas comment avec ce faeux "tablo".
Merci
Cliquez pour agrandir...
Non tu as donné un tableau avec des référence, les autres champs son vide. Dommage j'avais peut-être une autre solution à te proposer mais il est impératif pour moi d'avoir une ou deux lignes complètes de données bidon qui reflète une certaine réalité .
 
Vote positif 0 Vote négatif
propostion pour les différents ensembles de colonnes

VB: 
Sub Transferer()
Dim i As Integer
Dim j As Integer
Dim Ind As Integer
Dim NbLig As Integer
Dim Trouvé As Boolean
Dim LigDest As Integer
Dim RefDev As String
Dim TSCommande As ListObject
Dim TSMaj As ListObject
Dim TabCommande() As Variant
Dim TabMaj() As Variant
Dim NbCol As Integer
Dim start As Single
start = Timer

    'Définition des Tables structurées
    Set TSCommande = Sheets("Commande").ListObjects("TbCommande")
    Set TSMaj = Sheets("MAJ").ListObjects("TbMaj")
    
    With TSCommande 'avec la TS "TbCommande"
        TabCommande = .DataBodyRange.Value '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    With TSMaj 'avec la TS "TbMaj"
        TabMaj = Application.WorksheetFunction.Transpose(.DataBodyRange.Value) 'Application.WorksheetFunction.Transpose(.ListColumns(1).DataBodyRange.Resize(, 10).Value) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    NbCol = UBound(TabCommande, 2)
    
    NbLig = 0 'initialisation
    For i = LBound(TabCommande, 1) To UBound(TabCommande, 1) 'pour chaque ligne du tablo
        RefDev = TabCommande(i, 1) 'on récupère la Ref dans la colonne 1
        Trouvé = False 'initialisation
        For Ind = LBound(TabMaj, 2) To UBound(TabMaj, 2)  'on cherche si la référence est déjà dans le tablo TabMaj
            If TabMaj(1, Ind) = RefDev Then 'on la trouve
                LigDest = Ind 'on note la ligne
                Trouvé = True 'on met à vrai
                Exit For 'on sort de la boucle
            End If
        Next Ind
        If Not Trouvé Then 'si pas trouvé (on a donc parcouru TOUT le tablo
            NbLig = NbLig + 1 'on ajoute une ligne
            ReDim Preserve TabMaj(1 To NbCol, 1 To NbLig) 'on dimensionne le tablo TabMaj
            LigDest = NbLig 'on note la ligne
        End If
        
        For j = 1 To 10 'on remplit les infos pour les colonnes A:J
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 16 To 18 'on remplit les infos pour les colonnes P:R
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 42 To 48 'on remplit les infos pour les colonnes AP:AV
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
    Next i
    
    With TSMaj 'avec la table
        Dim ListCol
        Dim ExtractCol
        Dim TabTransp
        ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
        TabTransp = Application.WorksheetFunction.Transpose(TabMaj)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 1).Resize(UBound(TabTransp, 2), 10) = ExtractCol 'on bascule le résultat
        
        ListCol = Array(16, 17, 18)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 16).Resize(UBound(TabTransp, 2), 3) = ExtractCol 'on bascule le résultat
        
        ListCol = Array(42, 43, 44, 45, 46, 47, 48)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 42).Resize(UBound(TabTransp, 2), 7) = ExtractCol 'on bascule le résultat
        
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
End Sub
 
Vote positif 0 Vote négatif
dysorthographie à dit:
Non tu as donné un tableau avec des référence, les autres champs son vide. Dommage j'avais peut-être une autre solution à te proposer mais il est impératif pour moi d'avoir une ou deux lignes complètes de données bidon qui reflète une certaine réalité .
Cliquez pour agrandir...
Est-ce que cela convient comme exemple?
Merci
 

Pièces jointes

Vote positif 0 Vote négatif
vgendron à dit:
propostion pour les différents ensembles de colonnes

VB: 
Sub Transferer()
Dim i As Integer
Dim j As Integer
Dim Ind As Integer
Dim NbLig As Integer
Dim Trouvé As Boolean
Dim LigDest As Integer
Dim RefDev As String
Dim TSCommande As ListObject
Dim TSMaj As ListObject
Dim TabCommande() As Variant
Dim TabMaj() As Variant
Dim NbCol As Integer
Dim start As Single
start = Timer

    'Définition des Tables structurées
    Set TSCommande = Sheets("Commande").ListObjects("TbCommande")
    Set TSMaj = Sheets("MAJ").ListObjects("TbMaj")
   
    With TSCommande 'avec la TS "TbCommande"
        TabCommande = .DataBodyRange.Value '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    With TSMaj 'avec la TS "TbMaj"
        TabMaj = Application.WorksheetFunction.Transpose(.DataBodyRange.Value) 'Application.WorksheetFunction.Transpose(.ListColumns(1).DataBodyRange.Resize(, 10).Value) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    NbCol = UBound(TabCommande, 2)
   
    NbLig = 0 'initialisation
    For i = LBound(TabCommande, 1) To UBound(TabCommande, 1) 'pour chaque ligne du tablo
        RefDev = TabCommande(i, 1) 'on récupère la Ref dans la colonne 1
        Trouvé = False 'initialisation
        For Ind = LBound(TabMaj, 2) To UBound(TabMaj, 2)  'on cherche si la référence est déjà dans le tablo TabMaj
            If TabMaj(1, Ind) = RefDev Then 'on la trouve
                LigDest = Ind 'on note la ligne
                Trouvé = True 'on met à vrai
                Exit For 'on sort de la boucle
            End If
        Next Ind
        If Not Trouvé Then 'si pas trouvé (on a donc parcouru TOUT le tablo
            NbLig = NbLig + 1 'on ajoute une ligne
            ReDim Preserve TabMaj(1 To NbCol, 1 To NbLig) 'on dimensionne le tablo TabMaj
            LigDest = NbLig 'on note la ligne
        End If
       
        For j = 1 To 10 'on remplit les infos pour les colonnes A:J
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 16 To 18 'on remplit les infos pour les colonnes P:R
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 42 To 48 'on remplit les infos pour les colonnes AP:AV
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
    Next i
   
    With TSMaj 'avec la table
        Dim ListCol
        Dim ExtractCol
        Dim TabTransp
        ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
        TabTransp = Application.WorksheetFunction.Transpose(TabMaj)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 1).Resize(UBound(TabTransp, 2), 10) = ExtractCol 'on bascule le résultat
       
        ListCol = Array(16, 17, 18)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 16).Resize(UBound(TabTransp, 2), 3) = ExtractCol 'on bascule le résultat
       
        ListCol = Array(42, 43, 44, 45, 46, 47, 48)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 42).Resize(UBound(TabTransp, 2), 7) = ExtractCol 'on bascule le résultat
       
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
End Sub
Cliquez pour agrandir...
Je vais tester mais cela risque de prendre un peu de temps, je dois m'assurer que les données des autres colonnes dans TbMAJ ne sont pas altérées.
Je te redis cela au plus vite!!!
Merci 1000 fois
 
Vote positif 0 Vote négatif
vgendron à dit:
propostion pour les différents ensembles de colonnes

VB: 
Sub Transferer()
Dim i As Integer
Dim j As Integer
Dim Ind As Integer
Dim NbLig As Integer
Dim Trouvé As Boolean
Dim LigDest As Integer
Dim RefDev As String
Dim TSCommande As ListObject
Dim TSMaj As ListObject
Dim TabCommande() As Variant
Dim TabMaj() As Variant
Dim NbCol As Integer
Dim start As Single
start = Timer

    'Définition des Tables structurées
    Set TSCommande = Sheets("Commande").ListObjects("TbCommande")
    Set TSMaj = Sheets("MAJ").ListObjects("TbMaj")
   
    With TSCommande 'avec la TS "TbCommande"
        TabCommande = .DataBodyRange.Value '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    With TSMaj 'avec la TS "TbMaj"
        TabMaj = Application.WorksheetFunction.Transpose(.DataBodyRange.Value) 'Application.WorksheetFunction.Transpose(.ListColumns(1).DataBodyRange.Resize(, 10).Value) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    NbCol = UBound(TabCommande, 2)
   
    NbLig = 0 'initialisation
    For i = LBound(TabCommande, 1) To UBound(TabCommande, 1) 'pour chaque ligne du tablo
        RefDev = TabCommande(i, 1) 'on récupère la Ref dans la colonne 1
        Trouvé = False 'initialisation
        For Ind = LBound(TabMaj, 2) To UBound(TabMaj, 2)  'on cherche si la référence est déjà dans le tablo TabMaj
            If TabMaj(1, Ind) = RefDev Then 'on la trouve
                LigDest = Ind 'on note la ligne
                Trouvé = True 'on met à vrai
                Exit For 'on sort de la boucle
            End If
        Next Ind
        If Not Trouvé Then 'si pas trouvé (on a donc parcouru TOUT le tablo
            NbLig = NbLig + 1 'on ajoute une ligne
            ReDim Preserve TabMaj(1 To NbCol, 1 To NbLig) 'on dimensionne le tablo TabMaj
            LigDest = NbLig 'on note la ligne
        End If
       
        For j = 1 To 10 'on remplit les infos pour les colonnes A:J
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 16 To 18 'on remplit les infos pour les colonnes P:R
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 42 To 48 'on remplit les infos pour les colonnes AP:AV
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
    Next i
   
    With TSMaj 'avec la table
        Dim ListCol
        Dim ExtractCol
        Dim TabTransp
        ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
        TabTransp = Application.WorksheetFunction.Transpose(TabMaj)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 1).Resize(UBound(TabTransp, 2), 10) = ExtractCol 'on bascule le résultat
       
        ListCol = Array(16, 17, 18)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 16).Resize(UBound(TabTransp, 2), 3) = ExtractCol 'on bascule le résultat
       
        ListCol = Array(42, 43, 44, 45, 46, 47, 48)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 42).Resize(UBound(TabTransp, 2), 7) = ExtractCol 'on bascule le résultat
       
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
End Sub
Cliquez pour agrandir...
Lors de mon premier test, il ne copie que 140 lignes sur 1255
Et puis dans mon explication, j'ai oublié une chose importante, c'est que
- lorsque que la référence devis n'existe pas dans TbMAJ, il faut copier toute la ligne, par contre si la reférence devis existe déjà dans TbMAJ, il faut juste modifier les données des colonnes concernées (oui je sais je me réveille un peu tard), désolé
Tu vas me hair
 
Vote positif 0 Vote négatif
dysorthographie à dit:
C'est parfait
Cliquez pour agrandir...
Merci
Par contre dans mon explication, j'ai oublié une chose importante, c'est que
- lorsque que la référence devis n'existe pas dans TbMAJ, il faut copier toute la ligne, par contre si la reférence devis existe déjà dans TbMAJ, il faut juste modifier les données des colonnes concernées (oui je sais je me réveille un peu tard), désolé
Tu vas me hair
 
Vote positif 0 Vote négatif
eric72 à dit:
Lors de mon premier test, il ne copie que 140 lignes sur 1255
Cliquez pour agrandir...
exact.. je me suis planté dans les noms de tableau et indices

VB: 
Sub Transferer()
Dim i As Integer
Dim j As Integer
Dim Ind As Integer
Dim NbLig As Integer
Dim Trouvé As Boolean
Dim LigDest As Integer
Dim RefDev As String
Dim TSCommande As ListObject
Dim TSMaj As ListObject
Dim TabCommande() As Variant
Dim TabMaj() As Variant
Dim NbCol As Integer
Dim start As Single
start = Timer
Application.ScreenUpdating = False

    'Définition des Tables structurées
    Set TSCommande = Sheets("Commande").ListObjects("TbCommande")
    Set TSMaj = Sheets("MAJ").ListObjects("TbMaj")
    
    With TSCommande 'avec la TS "TbCommande"
        TabCommande = .DataBodyRange.Value '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    With TSMaj 'avec la TS "TbMaj"
        TabMaj = Application.WorksheetFunction.Transpose(.DataBodyRange) '.Value 'Application.WorksheetFunction.Transpose(.ListColumns(1).DataBodyRange.Resize(, 10).Value) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
    End With
    NbCol = UBound(TabCommande, 2)
    NbLig = UBound(TabMaj, 2)
    NbLig = 0 'initialisation
    For i = LBound(TabCommande, 1) To UBound(TabCommande, 1) 'pour chaque ligne du tablo
        RefDev = TabCommande(i, 1) 'on récupère la Ref dans la colonne 1
        Trouvé = False 'initialisation
        For Ind = LBound(TabMaj, 2) To UBound(TabMaj, 2)  'on cherche si la référence est déjà dans le tablo TabMaj
            If TabMaj(1, Ind) = RefDev Then 'on la trouve
                LigDest = Ind 'on note la ligne
                Trouvé = True 'on met à vrai
                Exit For 'on sort de la boucle
            End If
        Next Ind
        If Not Trouvé Then 'si pas trouvé (on a donc parcouru TOUT le tablo
            NbLig = NbLig + 1 'on ajoute une ligne
            ReDim Preserve TabMaj(1 To NbCol, 1 To NbLig) 'on dimensionne le tablo TabMaj
            LigDest = NbLig 'on note la ligne
        End If
        
        For j = 1 To 10 'on remplit les infos pour les colonnes A:J
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 16 To 18 'on remplit les infos pour les colonnes P:R
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
        For j = 42 To 48 'on remplit les infos pour les colonnes AP:AV
            TabMaj(j, LigDest) = TabCommande(i, j)
        Next j
    Next i
    
    With TSMaj 'avec la table
        Dim ListCol
        Dim ExtractCol
        Dim TabTransp
        
        .DataBodyRange.Delete
        .ListRows.Add
        ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
        TabTransp = Application.WorksheetFunction.Transpose(TabMaj)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 1).Resize(UBound(ExtractCol, 1), 10) = ExtractCol 'on bascule le résultat
        
        ListCol = Array(16, 17, 18)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 16).Resize(UBound(ExtractCol, 1), 3) = ExtractCol 'on bascule le résultat
        
        ListCol = Array(42, 43, 44, 45, 46, 47, 48)
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
        .DataBodyRange(1, 42).Resize(UBound(ExtractCol, 1), 7) = ExtractCol 'on bascule le résultat
        
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
    Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

E
  • Résolu(e)
Microsoft 365 Reduire Temps Execution Code
Réponses
5
Affichages
283
eric72
E
A
  • Question Question
XL 2016 Procédure trop longue pour une macro existante
2
Réponses
16
Affichages
2 K
ChTi160
ChTi160
V
  • Question Question
Macro d'export de donnée : erreur 1004
Réponses
5
Affichages
1 K
Roland_M
Roland_M
R
  • Question Question
macro remplissage cellule par incrémentation suivant plusieurs valeurs
Réponses
6
Affichages
3 K
racoune
R
S
  • Question Question
[Résolu] Petite macro simple avec une double boucle sur ligne pour très gros fichier
2
Réponses
27
Affichages
6 K
stephsteph
S
M
  • Question Question
Macro trop longue
Réponses
6
Affichages
2 K
Tirou
T
W
  • Question Question
Recalcul automatique par macro qui ne fonctionne pas
Réponses
2
Affichages
1 K
whiskyfizz
W
B
  • Question Question
code VBA execution trop longue
Réponses
9
Affichages
3 K
bigmousse
B
S
  • Question Question
Formule par macro trop longue
Réponses
5
Affichages
1 K
sebastien450
S
SaM`
  • Question Question
[MACRO] Report du Solde
Réponses
4
Affichages
2 K
SaM`
SaM`
M
[REF] Wiki Page 9 de MichelXld
Réponses
0
Affichages
39 K
MichelXld
M
M
[REF] Wiki Page 7 de MichelXld
Réponses
0
Affichages
51 K
MichelXld
M
M
[REF] Wiki 5 de MichelXld (Formules, Audits de formules, Répertoires, Fichiers)
Réponses
0
Affichages
47 K
MichelXld
M
Retour