Option Explicit
Sub Copier_Alternant()
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 NomPrenom As String
Dim TSAlternant As ListObject
Dim TSArchiveAlternant As ListObject
Dim TabAlternant() As Variant
Dim TabArchiveAlternant() As Variant
Dim LastLine As Integer
Dim TabNew() As Variant
Dim NbNew As Integer
Dim NbCol As Integer
Application.ScreenUpdating = False
'Définition des Tables structurées
Set TSAlternant = Sheets("Import").ListObjects("TbAlternant")
Set TSArchiveAlternant = Sheets("Archive Alternant").ListObjects("TbArchiveAlternant")
With TSAlternant 'avec la TS "TSAlternant"
If .ListRows.Count = 0 Then Exit Sub
'MsgBox TSAlternant.ListColumns(1).DataBodyRange(1)
TabAlternant = .DataBodyRange.Value2 '.ListColumns(1).DataBodyRange.Resize(, 11).Value 'on met tout (sauf la ligne d'entete) dans un tablo VBA
End With
With TSArchiveAlternant 'avec la TS "TSArchiveAlternant"
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(TabAlternant, 1), UBound(TabAlternant, 2)) = TabAlternant 'on colle directement le TabAlternant
'MsgBox "durée du traitement: " & Timer - start & " secondes"
Application.ScreenUpdating = True
Exit Sub ' et c'est fini
Else
TabArchiveAlternant = Application.WorksheetFunction.Transpose(.DataBodyRange) 'on met tout (sauf la ligne d'entete) dans un tablo VBA
NbLig = UBound(TabArchiveAlternant, 2) 'on récupère le nombre de lignes
'MsgBox UBound(TabArchiveAlternant, 1)
End If
End With
NbCol = UBound(TabAlternant, 2) 'on récupère le nombre de colonnes
NbNew = 0 'initialisation du nombre de nouvelles lignes
For i = LBound(TabAlternant, 1) To UBound(TabAlternant, 1) 'pour chaque ligne du tablo
NomPrenom = TabAlternant(i, 1) 'on récupère la Ref dans la colonne 1
Trouvé = False 'initialisation
For Ind = LBound(TabArchiveAlternant, 2) To UBound(TabArchiveAlternant, 2) 'on cherche si la référence est déjà dans le tablo TabArchiveAlternant
If TabArchiveAlternant(1, Ind) = NomPrenom 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(TabAlternant, 2) To UBound(TabAlternant, 2) 'on rempli avec TOUTE la ligne
TabNew(j, NbNew) = TabAlternant(i, j)
Next j
Else 'on ne remplit que certaines colonnes
For j = 1 To 11 'on remplit les infos pour les colonnes [NOM - PRENOM]:[COMMENTAIRES] COL 1 à COL 11
TabArchiveAlternant(j, LigDest) = TabAlternant(i, j)
Next j
End If
Next i
With TSArchiveAlternant 'avec la table
Dim ListCol
Dim ExtractCol
Dim TabTransp
ListCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11) 'liste des colonnes à extraire du tablo
If .ListRows.Count = 1 Then 'si UNE seule ligne dans TSArchiveAlternant (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(TabArchiveAlternant, 1) To NbCol
TabTransp(1, j) = TabArchiveAlternant(j, 1)
Next j
Else
TabTransp = Application.WorksheetFunction.Transpose(TabArchiveAlternant) 'on peut directement transposer
End If
ExtractCol = Application.Index(TabTransp, Evaluate("row(1:" & UBound(TabTransp) & ")"), ListCol) 'on extrait les colonnes
.DataBodyRange(1, 1).Resize(1, UBound(ExtractCol, 1)) = 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
