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
