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:
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
Cliquez pour agrandir...
c'est bien mieux mais j'ai une erreur 1004 de manière aléatoire ici
ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
mais cela devient bon!!! lol
 
Vote positif 0 Vote négatif
eric72 à dit:
c'est bien mieux mais j'ai une erreur 1004 de manière aléatoire ici
ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol)
mais cela devient bon!!! lol
Cliquez pour agrandir...
En fait l'erreur provenait probablement d'un click dans une cellule lors de l'exécution, cela fonctionne bien.
Il ne reste que mon problème de tout copier si la réf n'existe pas et là...
 
Vote positif 0 Vote négatif
et voila !!

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 TabNew() As Variant
Dim NbNew As Integer
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)
    NbNew = 0
    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
            NbNew = NbNew + 1 'on ajoute une ligne
            ReDim Preserve TabNew(1 To NbCol, 1 To NbNew) 'on dimensionne le tablo TabMaj
            For j = LBound(TabCommande, 2) To UBound(TabCommande, 2)
                TabNew(j, NbNew) = TabCommande(i, j)
            Next j
        Else
            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
        End If
    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
        
        If NbNew <> 0 Then
            Lastline = .ListRows.Add.Index
            .DataBodyRange(Lastline, 1).Resize(UBound(TabNew, 2), UBound(TabNew, 1)) = Application.WorksheetFunction.Transpose(TabNew)
        End If
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
    Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
VB: 
Sub test()
Dim Sql As String, L As Integer
L = Sheets("MAJ").Range("A1").CurrentRegion.Rows.Count + 1
Sql = " Select [Commande$].* from [Commande$] left join [MAJ$] on [MAJ$].[Référence Devis]= [Commande$].[Référence Devis] wHere [MAJ$].[Référence Devis] is null"
With CreateObject("AdoDb.connection")
   .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"""
  Sheets("MAJ").Cells(L, "A").CopyFromRecordset .Execute(Sql)
    .Close
End With
End Sub
 
Vote positif 0 Vote négatif
vgendron à dit:
et voila !!

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 TabNew() As Variant
Dim NbNew As Integer
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)
    NbNew = 0
    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
            NbNew = NbNew + 1 'on ajoute une ligne
            ReDim Preserve TabNew(1 To NbCol, 1 To NbNew) 'on dimensionne le tablo TabMaj
            For j = LBound(TabCommande, 2) To UBound(TabCommande, 2)
                TabNew(j, NbNew) = TabCommande(i, j)
            Next j
        Else
            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
        End If
    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
       
        If NbNew <> 0 Then
            Lastline = .ListRows.Add.Index
            .DataBodyRange(Lastline, 1).Resize(UBound(TabNew, 2), UBound(TabNew, 1)) = Application.WorksheetFunction.Transpose(TabNew)
        End If
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
    Application.ScreenUpdating = True
EnAppar
[QUOTE="vgendron, post: 20675444, member: 83052"]
et voila !!

[CODE=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 TabNew() As Variant
Dim NbNew As Integer
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)
    NbNew = 0
    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
            NbNew = NbNew + 1 'on ajoute une ligne
            ReDim Preserve TabNew(1 To NbCol, 1 To NbNew) 'on dimensionne le tablo TabMaj
            For j = LBound(TabCommande, 2) To UBound(TabCommande, 2)
                TabNew(j, NbNew) = TabCommande(i, j)
            Next j
        Else
            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
        End If
    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
       
        If NbNew <> 0 Then
            Lastline = .ListRows.Add.Index
            .DataBodyRange(Lastline, 1).Resize(UBound(TabNew, 2), UBound(TabNew, 1)) = Application.WorksheetFunction.Transpose(TabNew)
        End If
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
    Application.ScreenUpdating = True
End Sub
Cliquez pour agrandir...
Apparemment la variable Lastline n'est pas définie
[/QUOTE]
Merci
 
Vote positif 0 Vote négatif
vgendron à dit:
et voila !!

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 TabNew() As Variant
Dim NbNew As Integer
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)
    NbNew = 0
    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
            NbNew = NbNew + 1 'on ajoute une ligne
            ReDim Preserve TabNew(1 To NbCol, 1 To NbNew) 'on dimensionne le tablo TabMaj
            For j = LBound(TabCommande, 2) To UBound(TabCommande, 2)
                TabNew(j, NbNew) = TabCommande(i, j)
            Next j
        Else
            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
        End If
    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
       
        If NbNew <> 0 Then
            Lastline = .ListRows.Add.Index
            .DataBodyRange(Lastline, 1).Resize(UBound(TabNew, 2), UBound(TabNew, 1)) = Application.WorksheetFunction.Transpose(TabNew)
        End If
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
    Application.ScreenUpdating = True
End Sub
Cliquez pour agrandir...
la variable Lastline
 
Vote positif 0 Vote négatif
et pour éviter de perdre des infos de la table maj

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 LastLine As Integer
Dim TabNew() As Variant
Dim NbNew As Integer
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)
    NbNew = 0
    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é alors qu'on a parcouru TOUT le tablo
            NbNew = NbNew + 1 'on ajoute une ligne
            ReDim Preserve TabNew(1 To NbCol, 1 To NbNew) 'on dimensionne le tablo NbNew
            For j = LBound(TabCommande, 2) To UBound(TabCommande, 2) 'on rempli avec TOUTE la ligne
                TabNew(j, NbNew) = TabCommande(i, j)
            Next j
        Else 'on ne remplit que certaines colonnes
            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
        End If
    Next i
    
    With TSMaj 'avec la table
        Dim ListCol
        Dim ExtractCol
        Dim TabTransp
        
        '.DataBodyRange.Delete 'on vide la table
        '.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
        
        If NbNew <> 0 Then
            LastLine = .ListRows.Add.Index
            .DataBodyRange(LastLine, 1).Resize(UBound(TabNew, 2), UBound(TabNew, 1)) = Application.WorksheetFunction.Transpose(TabNew)
        End If
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
    Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
vgendron à dit:
et pour éviter de perdre des infos de la table maj

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 LastLine As Integer
Dim TabNew() As Variant
Dim NbNew As Integer
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)
    NbNew = 0
    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é alors qu'on a parcouru TOUT le tablo
            NbNew = NbNew + 1 'on ajoute une ligne
            ReDim Preserve TabNew(1 To NbCol, 1 To NbNew) 'on dimensionne le tablo NbNew
            For j = LBound(TabCommande, 2) To UBound(TabCommande, 2) 'on rempli avec TOUTE la ligne
                TabNew(j, NbNew) = TabCommande(i, j)
            Next j
        Else 'on ne remplit que certaines colonnes
            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
        End If
    Next i
   
    With TSMaj 'avec la table
        Dim ListCol
        Dim ExtractCol
        Dim TabTransp
       
        '.DataBodyRange.Delete 'on vide la table
        '.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
       
        If NbNew <> 0 Then
            LastLine = .ListRows.Add.Index
            .DataBodyRange(LastLine, 1).Resize(UBound(TabNew, 2), UBound(TabNew, 1)) = Application.WorksheetFunction.Transpose(TabNew)
        End If
    End With

    MsgBox "durée du traitement: " & Timer - start & " secondes"
    Application.ScreenUpdating = True
End Sub
Cliquez pour agrandir...
-Lorsque le TbMAJ est vide, les données des colonnes non concernées ne sont pas transférées, par contre lors d'une 2ème exécution de la macro, pour les nouveaux Ref Devis, les données sont bien toutes là.
-A partir du 2ème lancement de la macro, plus de #REF!
Je continue à tester mais ça a l'air efficace et 7 secondes pour 1255 lignes, bravo!!!
 
Vote positif 0 Vote négatif
dysorthographie à dit:
VB: 
Sub test()
Dim Sql As String, L As Integer
L = Sheets("MAJ").Range("A1").CurrentRegion.Rows.Count + 1
Sql = " Select [Commande$].* from [Commande$] left join [MAJ$] on [MAJ$].[Référence Devis]= [Commande$].[Référence Devis] wHere [MAJ$].[Référence Devis] is null"
With CreateObject("AdoDb.connection")
   .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"""
  Sheets("MAJ").Cells(L, "A").CopyFromRecordset .Execute(Sql)
    .Close
End With
End Sub
Cliquez pour agrandir...
Merci beaucoup
C'est génial mais ça ne correspond pas à ce que je souhaite, je me suis peut-être mal expliqué
Dans votre exemple l'ensemble de la ligne est transférée, alors que ce dont j'ai besoin c'est
- Si la Référence Devis n'existe pas dans TbMAJ, alors on transfère toute la ligne, par contre
- Si la Référence Devis existe déjà, j'aimerais que seules les données de certaines colonnes soient transférées, par exemple de la colonne A à J, puis de P à R Etc... et cela sans modifier les autres colonnes (K,L,M,N,O) dans TbMAJ
Je sais c'est un peu casse tête, dommage car le temps d'exécution est immédiat, bravo
 
Vote positif 0 Vote négatif
en ajoutant une "rustine" de plus

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 LastLine As Integer
Dim TabNew() As Variant
Dim NbNew As Integer
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"
        If .ListRows.Count <> 0 Then
            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
            NbLig = UBound(TabMaj, 2)
        Else
            .ListRows.Add
            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
            NbLig = UBound(TabMaj, 2)
        End If
    End With
    NbCol = UBound(TabCommande, 2)
    
    NbNew = 0
    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é alors qu'on a parcouru TOUT le tablo
            NbNew = NbNew + 1 'on ajoute une ligne
            ReDim Preserve TabNew(1 To NbCol, 1 To NbNew) 'on dimensionne le tablo NbNew
            For j = LBound(TabCommande, 2) To UBound(TabCommande, 2) 'on rempli avec TOUTE la ligne
                TabNew(j, NbNew) = TabCommande(i, j)
            Next j
        Else 'on ne remplit que certaines colonnes
            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
        End If
    Next i
    
    With TSMaj 'avec la table
        Dim ListCol
        Dim ExtractCol
        Dim TabTransp
        
        '.DataBodyRange.Delete
        '.ListRows.Add
        If NbLig >= 1 And TabMaj(1, 1) <> "" Then
        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 If
        If NbNew <> 0 Then
            LastLine = .ListRows.Add.Index
            .DataBodyRange(LastLine, 1).Resize(UBound(TabNew, 2), UBound(TabNew, 1)) = Application.WorksheetFunction.Transpose(TabNew)
        End If
    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