Microsoft 365 duree macro trop longue

eric72 · 13 Janvier 2025

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

eric72 · 14 Janvier 2025

vgendron à dit:

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

Il y a toujours au premier lancement les 140 lignes avec des #REF!, mais après c'est bon, je teste tout cela avec attention et te tiens au courant.
Quel boulot tu as fait, c'est magique.
Merci beaucoup

vgendron · 14 Janvier 2025

eric72 à dit:
l y a toujours au premier lancement les 140 lignes avec des #REF!,

bah normalement non.. en tout cas pas chez moi

eric72 · 14 Janvier 2025

vgendron à dit:
bah normalement non.. en tout cas pas chez moi

ça n'est pas grave, d'autant que je vais l'appliquer sur des tableaux déjà remplis donc je n'aurais pas le problème
Je te remercie 1000 fois pour tout le temps que tu as consacré à ce projet, tu m'enlèves une belle épine du pied.
Je continue à tester...

vgendron · 14 Janvier 2025

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 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 'la table Maj est vide
            'on copie directement le contenu de la commande vers Maj
            .ListRows.Add
            .DataBodyRange(1, 1).Resize(UBound(TabCommande, 1), UBound(TabCommande, 2)) = TabCommande
            MsgBox "durée du traitement: " & Timer - start & " secondes"
            Application.ScreenUpdating = True
            Exit Sub ' et c'est fini
        Else
            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

dysorthographie · 14 Janvier 2025

Mon script SQL transfert toutes les lignes don la référence n'existe pas dans TbMAJ

eric72 · 14 Janvier 2025

dysorthographie à dit:
Mon script SQL transfert toutes les lignes don la référence n'existe pas dans TbMAJ

Oui en effet, mais cela ne correspond pas à mes besoins, par contre je garde l'idée pour d'autres cas.
Merci beaucoup

eric72 · 14 Janvier 2025

vgendron à dit:

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 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 'la table Maj est vide
            'on copie directement le contenu de la commande vers Maj
            .ListRows.Add
            .DataBodyRange(1, 1).Resize(UBound(TabCommande, 1), UBound(TabCommande, 2)) = TabCommande
            MsgBox "durée du traitement: " & Timer - start & " secondes"
            Application.ScreenUpdating = True
            Exit Sub ' et c'est fini
        Else
            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
  
[QUOTE="vgendron, post: 20675474, member: 83052"]
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)
[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 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 'la table Maj est vide
            'on copie directement le contenu de la commande vers Maj
            .ListRows.Add
            .DataBodyRange(1, 1).Resize(UBound(TabCommande, 1), UBound(TabCommande, 2)) = TabCommande
            MsgBox "durée du traitement: " & Timer - start & " secondes"
            Application.ScreenUpdating = True
            Exit Sub ' et c'est fini
        Else
            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

En effet, c'est beaucoup mieux, un petit truc bizarre
[/QUOTE]
- 1er lancement de la macro les montant devis sont bien transférés
- 2ème lancement, il me met le "ATTENTION" pour convertir en nombre.
Pour le reste , top top top!!!

vgendron · 14 Janvier 2025

je viens de voir un autre "bug" que je ne m'explique pas

à partir de maj vide
1er lancement ==> tout est copié =>OK
2eme lancement (sans rien modifier nulle part) ==> la ligne 5 est partiellement effacée..??

eric72 · 14 Janvier 2025

vgendron à dit:

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 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 'la table Maj est vide
            'on copie directement le contenu de la commande vers Maj
            .ListRows.Add
            .DataBodyRange(1, 1).Resize(UBound(TabCommande, 1), UBound(TabCommande, 2)) = TabCommande
            MsgBox "durée du traitement: " & Timer - start & " secondes"
            Application.ScreenUpdating = True
            Exit Sub ' et c'est fini
        Else
            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

Il suffisait juste d'éviter le format monétaire, il ne doit pas aimer les €

vgendron à dit:
je viens de voir un autre "bug" que je ne m'explique pas

à partir de maj vide
1er lancement ==> tout est copié =>OK
2eme lancement (sans rien modifier nulle part) ==> la ligne 5 est partiellement effacée..??

Ah je vais tester pour voir

vgendron · 14 Janvier 2025

Pour le bug.. ca dépend des données apparemment..
j'ai mis des données bidons.. et j'ai plus le bug.. ??

eric72 · 14 Janvier 2025

vgendron à dit:
Pour le bug.. ca dépend des données apparemment..
j'ai mis des données bidons.. et j'ai plus le bug.. ??

Ah bizarre, je fais es essais et je n'ai pas le cas, tu te rappelles du type de données que tu avais mis?

vgendron · 14 Janvier 2025

Celles que tu as mises dans ton deuxième fichier pour répondre à la demande de dysorthographie

vgendron · 14 Janvier 2025

Ce code fonctionne quelque soit le nombre de lignes dans la table maj ==> plus de #ref

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 'la table Maj est vide
            'on copie directement le contenu de la commande vers Maj
            .ListRows.Add 'on ajoute une ligne vide
            .DataBodyRange(1, 1).Resize(UBound(TabCommande, 1), UBound(TabCommande, 2)) = TabCommande 'on colle directement le tabcommande
            'MsgBox "durée du traitement: " & Timer - start & " secondes"
            Application.ScreenUpdating = True
            Exit Sub ' et c'est fini
        Else
            TabMaj = Application.WorksheetFunction.Transpose(.DataBodyRange) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
            NbLig = UBound(TabMaj, 2) 'on récupère le nombre de lignes
        End If
    End With
    
    NbCol = UBound(TabCommande, 2) 'on récupère le nombre de colonnes
    
    NbNew = 0 'initialisation du nombre de nouvelles lignes
    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
        
        ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) 'liste des colonnes à extraire du tablo
        
        If .ListRows.Count = 1 Then 'si UNE seule ligne dans TSMaj (avant le transfert) ==> le transpose d'une ligne vers une colonne ne fonctionne pas ==> on créé manuellement le tabtransp
            ReDim TabTransp(1 To 1, 1 To NbCol)
            For j = LBound(TabMaj, 1) To UBound(TabMaj, 1)
                TabTransp(1, j) = TabMaj(j, 1)
            Next j
        Else
            TabTransp = Application.WorksheetFunction.Transpose(TabMaj) 'on peut directement transposer
        End If
        
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol) 'on extrait les colonnes
        .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 'si on a des nouvelles lignes ==> on les colle en bas de tablo
            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

eric72 · 15 Janvier 2025

vgendron à dit:

Ce code fonctionne quelque soit le nombre de lignes dans la table maj ==> plus de #ref

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 'la table Maj est vide
            'on copie directement le contenu de la commande vers Maj
            .ListRows.Add 'on ajoute une ligne vide
            .DataBodyRange(1, 1).Resize(UBound(TabCommande, 1), UBound(TabCommande, 2)) = TabCommande 'on colle directement le tabcommande
            'MsgBox "durée du traitement: " & Timer - start & " secondes"
            Application.ScreenUpdating = True
            Exit Sub ' et c'est fini
        Else
            TabMaj = Application.WorksheetFunction.Transpose(.DataBodyRange) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
            NbLig = UBound(TabMaj, 2) 'on récupère le nombre de lignes
        End If
    End With
   
    NbCol = UBound(TabCommande, 2) 'on récupère le nombre de colonnes
   
    NbNew = 0 'initialisation du nombre de nouvelles lignes
    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
       
        ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) 'liste des colonnes à extraire du tablo
       
        If .ListRows.Count = 1 Then 'si UNE seule ligne dans TSMaj (avant le transfert) ==> le transpose d'une ligne vers une colonne ne fonctionne pas ==> on créé manuellement le tabtransp
            ReDim TabTransp(1 To 1, 1 To NbCol)
            For j = LBound(TabMaj, 1) To UBound(TabMaj, 1)
                TabTransp(1, j) = TabMaj(j, 1)
            Next j
        Else
            TabTransp = Application.WorksheetFunction.Transpose(TabMaj) 'on peut directement transposer
        End If
       
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol) 'on extrait les colonnes
        .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 'si on a des nouvelles lignes ==> on les colle en bas de tablo
            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

Bonjour,
Décidemment tu ne lâches rien!!! c'est génial
Merci beaucoup pour ce que tu as fait, le temps est d'environ 1 seconde (à partir du 2ème lancement de la macro) au lieu d'une trentaine de secondes...
C'est énormeeeeeee

eric72 · 22 Janvier 2025

vgendron à dit:

Ce code fonctionne quelque soit le nombre de lignes dans la table maj ==> plus de #ref

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 'la table Maj est vide
            'on copie directement le contenu de la commande vers Maj
            .ListRows.Add 'on ajoute une ligne vide
            .DataBodyRange(1, 1).Resize(UBound(TabCommande, 1), UBound(TabCommande, 2)) = TabCommande 'on colle directement le tabcommande
            'MsgBox "durée du traitement: " & Timer - start & " secondes"
            Application.ScreenUpdating = True
            Exit Sub ' et c'est fini
        Else
            TabMaj = Application.WorksheetFunction.Transpose(.DataBodyRange) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
            NbLig = UBound(TabMaj, 2) 'on récupère le nombre de lignes
        End If
    End With
   
    NbCol = UBound(TabCommande, 2) 'on récupère le nombre de colonnes
   
    NbNew = 0 'initialisation du nombre de nouvelles lignes
    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
       
        ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) 'liste des colonnes à extraire du tablo
       
        If .ListRows.Count = 1 Then 'si UNE seule ligne dans TSMaj (avant le transfert) ==> le transpose d'une ligne vers une colonne ne fonctionne pas ==> on créé manuellement le tabtransp
            ReDim TabTransp(1 To 1, 1 To NbCol)
            For j = LBound(TabMaj, 1) To UBound(TabMaj, 1)
                TabTransp(1, j) = TabMaj(j, 1)
            Next j
        Else
            TabTransp = Application.WorksheetFunction.Transpose(TabMaj) 'on peut directement transposer
        End If
       
        ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol) 'on extrait les colonnes
        .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 'si on a des nouvelles lignes ==> on les colle en bas de tablo
            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

Bonjour vgendron,
Je viens de m'apercevoir que lors de la copie des données vers TbMAJ, certaines dates sont inversées exemple si on copie 08/04/2024, cela devient dans TbMAJ 04/08/2024, j'imagine que dans le code il faut préciser que telle colonne est une date mais je ne sais pas comment faire!!!
As-tu une idée.
En dehors de cela, ça fonctionne TOP
Merci

Effectuez une recherche sur Excel Downloads...

Microsoft 365 duree macro trop longue

eric72

XLDnaute Accro

vgendron

eric72

XLDnaute Accro

vgendron

XLDnaute Barbatruc

eric72

XLDnaute Accro

vgendron

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

eric72

XLDnaute Accro

eric72

XLDnaute Accro

vgendron

XLDnaute Barbatruc

eric72

XLDnaute Accro

vgendron

XLDnaute Barbatruc

eric72

XLDnaute Accro

vgendron

XLDnaute Barbatruc

vgendron

XLDnaute Barbatruc

eric72

XLDnaute Accro

eric72

XLDnaute Accro

Discussions similaires

Nous accordons de l'importance à votre vie privée