Microsoft 365 duree macro trop longue

[eric72]

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]

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

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

J'ai ajouté ce code ^pour chaque tranche à copier mais je ne sais pas si c'est la bonne solution
If IsDate(TabCommande(i, j)) Then TabCommande(i, j) = Int(TabCommande(i, j))
Merci

 

[vgendron]

Hello
je n'ai pas retrouvé le fichier que jai du supprimer

dans la macro essaie de remplacer

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

par

With TSCommande 'avec la TS "TbCommande"
    TabCommande = .DataBodyRange.Value2 '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
End With

 

[eric72]

Hello
je n'ai pas retrouvé le fichier que jai du supprimer

dans la macro essaie de remplacer

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

par

With TSCommande 'avec la TS "TbCommande"
    TabCommande = .DataBodyRange.Value2 '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
End With

En effet ça parait fonctionner, pour ma culture perso, en quoi le "value2" règle-t-il le problème.
Merci beaucoup

 

[vgendron]

Value2 ignore le formatage date et monétaire des cellules

Range.Value2, propriété (Excel)

Rubrique de référence sur Office VBA

learn.microsoft.com

 

[eric72]

Value2 ignore le formatage date et monétaire des cellules

Range.Value2, propriété (Excel)

Rubrique de référence sur Office VBA

learn.microsoft.com

Super merci beaucoup une nouvelle fois.
Bonne journée

 

[eric72]

Hello
je n'ai pas retrouvé le fichier que jai du supprimer

dans la macro essaie de remplacer

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

par

With TSCommande 'avec la TS "TbCommande"
    TabCommande = .DataBodyRange.Value2 '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
End With

Bonjour vgendron,
Nouveau petit problème, la copie se fait bien avec les dates au bon format, par contre s'il n'y a pas de date lors de la copie j'ai un #N/A dans TbMAJ, y-a-t-il un moyen d'éviter cela?
Merci et désolé pour le dérangement

 

[eric72]

Hello
je n'ai pas retrouvé le fichier que jai du supprimer

dans la macro essaie de remplacer

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

par

With TSCommande 'avec la TS "TbCommande"
    TabCommande = .DataBodyRange.Value2 '.ListColumns(1).DataBodyRange.Resize(, 10).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
End With

Mea Culpa, j'ai fait d'autres essais et ça ne le fait plus, j'ai du faire une boulette!!!
Désolé, bonne journée