Option Explicit
Sub Rassembler()
'Feuilles à traiter
Const cF = "JAL_AN/Gestion_Créancier/Gestion_Caisse/Gestion_Banque/JAL_OD"
'Ligne des en-têtes de chaque feuille à traiter
Const cFligneDebut = "11/9/9/11/11"
'Noms des champs à copier
Const cChamps = "N°compte gle/Mois/Date/Libellé/Débit/Crédit"
'Le & remplace ' as long', le $ remplace ' as string'
Dim i&, j&, DebLig&, Finlig&, NumCol
Dim F, FligneDebut, Champs, NomF$, sh As Sheets
Dim rgTitre As Range, rgAcopier As Range, rgBase As Range, rgIci As Range
'Split transforme une chaine de caractères en un tableau de mots à une dimension
'le séparateur de mots est le caractère /
'indice inf du tableau résultant est toujours 0 (jamais 1)
F = Split(cF, "/") 'tableau des noms des feuilles à traiter
FligneDebut = Split(cFligneDebut, "/") 'Tableau des n° ligne des en-têtes
Champs = Split(cChamps, "/") 'Tableau des champs à copier
'effacer précédent traitement
Sheets("TCD").Select
ActiveSheet.Unprotect "MDP"
Range("A2:H" & Rows.Count).Clear
Application.ScreenUpdating = False
'lbound(tablo,2) retourne le plus petit indice de la deuxième dimension de tablo
'ubound(tablo,1) retourne le plus grand indice de la première dimension de tablo
'ex: si DIM tablo( 0 to 4, 10 to 29) alors
'lbound(tablo,1)=0, ubound(tablo,1)=4, lbound(tablo,2)=10, ubound(tablo,2)=29
'si on traite la première dimension du tableau, on peut omettre ,1
'lbound(tablo)=0, ubound(tablo)=4
'Quand on ne connait pas à l'avance les bornes des indices d'un tableau, c'est pratique.
'Quand on ne sait plus si SPLIT donne des tableaux à base 0 ou 1, lbound et ubound
'permette de contourner cet oubli.
For i = LBound(F) To UBound(F)
'Boucle sur les noms de feuilles à traiter
NomF = F(i)
'ligne des en-têtes
DebLig = FligneDebut(i)
'recherche de la dernière ligne à copier
Finlig = Sheets(NomF).Range("b" & Rows.Count).End(xlUp).Row
If Finlig > DebLig Then
'il y a effectivement des données à copier
'Définir la cellule où copier les champs - on se base sur la colonne C des dates
Set rgBase = Range("c" & Rows.Count).End(xlUp).Offset(1, -2)
For j = LBound(Champs) To UBound(Champs)
'boucle sur les champs à copier
'définir la zone d'en-tête
Set rgTitre = Sheets(NomF).Range(Sheets(NomF).Cells(DebLig, "a"), Sheets(NomF).Cells(DebLig, "n"))
'on error resume next permet de continuer l'exécution si le champ cherché
'ne se trouve pas dans la ligne des titres
NumCol = 0
'rechercher le numéro de colonne du champ à copier dans la ligne d'en-têtes
On Error Resume Next
NumCol = Application.WorksheetFunction.Match(Champs(j), rgTitre, 0)
' NumCol = Application.WorksheetFunction.Match(Champs(j), rgTitre, 0)
' On Error GoTo 0 'on rétablit la détection d'erreur
If NumCol > 0 Then
'le champ a été trouvé (donc son numéro), on copie les données
Set rgAcopier = Sheets(NomF).Range(Sheets(NomF).Cells(DebLig + 1, NumCol), Sheets(NomF).Cells(Finlig, NumCol))
Set rgIci = rgBase.Offset(, j)
rgAcopier.Copy
rgIci.PasteSpecial xlPasteValues
rgIci.PasteSpecial xlPasteFormats
ElseIf NomF = "Gestion_Créancier" And Champs(j) = "Débit" Then
' le champ à copier est inconnu
'==> VERRUE 1 : feuille = "Gestion_Créancier" et Champs = "Débit"
'chercher le champ "Mtant TTC" (on suppose qu'il existe toujours)
'pas de gestion du cas où il serait inexistant!
NumCol = Application.WorksheetFunction.Match("Mtant TTC", rgTitre, 0)
Set rgAcopier = Sheets(NomF).Range(Sheets(NomF).Cells(DebLig + 1, NumCol), Sheets(NomF).Cells(Finlig, NumCol))
Set rgIci = rgBase.Offset(, j)
rgAcopier.Copy
rgIci.PasteSpecial xlPasteValues
rgIci.PasteSpecial xlPasteFormats
'chercher le champ "Dt TVA" (on suppose qu'il existe toujours)
'pas de gestion du cas où il serait inexistant!
NumCol = Application.WorksheetFunction.Match("Dt TVA", rgTitre, 0)
Set rgAcopier = Sheets(NomF).Range(Sheets(NomF).Cells(DebLig + 1, NumCol), Sheets(NomF).Cells(Finlig, NumCol))
Set rgIci = rgBase.Offset(, j)
rgAcopier.Copy
rgIci.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationSubtract
ElseIf NomF = "Gestion_Créancier" And Champs(j) = "Crédit" Then
'' le champ à copier est inconnu
'==> VERRUE 2 : feuille = "Gestion_Créancier" et Champs = "Crédit"
'chercher le champ "Mtant TTC" (on suppose qu'il existe toujours)
'pas de gestion du cas où il serait inexistant!
'on ne fait rien càd on laisse la cellule à vide
Else
'le champ à recopier n'existe pas et ne fait pas l'objet d'une VERRUE
'on y met le texte en rouge <Champs> PAS TROUVÉ
Set rgIci = rgBase.Offset(, j).Resize(Finlig - DebLig)
rgIci.Value = "Champ <" & Champs(j) & "> PAS TROUVÉ"
rgIci.Font.Bold = True
rgIci.Font.Color = RGB(255, 0, 0)
End If
Next j
Set rgIci = rgBase.Offset(, j).Resize(Finlig - DebLig)
rgIci = NomF
End If
Next i
Range("a1").CurrentRegionShrinkToFit = False
Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
Range("a1").CurrentRegion.FormatConditions.Delete
Range("a1").Resize(, UBound(Champs) - LBound(Champs) + 1).Value = Champs
Range("a1").Offset(, UBound(Champs) - LBound(Champs) + 1) = "Code JAL"
'déplacement de la dernière colonne de TCD (Code JAL) avant la colonne B
Columns(UBound(Champs) - LBound(Champs) + 2).Cut
Columns("B:B").Insert Shift:=xlToRight
Range("a1").CurrentRegion.EntireColumn.AutoFit
Range("a1").CurrentRegion.Rows(1).Interior.Color = RGB(200, 200, 200)
'VERRUE: Suppression des lignes où N°compte gle est à vide
Set rgAcopier = Nothing
On Error Resume Next
Set rgAcopier = Range("a1").CurrentRegion.Offset(1).Columns(1)
Set rgAcopier = rgAcopier.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rgAcopier Is Nothing Then
'il y a des cellules vide, on supprime leur ligne
rgAcopier.EntireRow.Delete
End If
'Création COLONNE Intitulé
Range("H1") = "Intitulé"
Range("H2").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[-7]),"""",CONCATENATE(RC[-7],"" - "",(LOOKUP(RC[-7],COMPTES,INTITULE_COMPTES))))"
Selection.Copy
Range("H3:H" & ActiveSheet.UsedRange.Rows.Count).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("H1").CurrentRegion.EntireColumn.AutoFit
'RANGER par N° de compte du plus petit au plus grand
Range("A1:H1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort.SortFields.Add Key:=Range( _
"A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1:H1").Select
Selection.AutoFilter
Range("a1").Select
Application.ScreenUpdating = True
ActiveSheet.protect "MDP"
End Sub