1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
| Option Explicit
'*******************************************************************************************************
' NAME : SpecCopy (PROCESS)
' DESCRIPTION : La procédure permet de consolider des données à partir de multiple feuille vers une
' feuille de synthèse
'*******************************************************************************************************
Public Sub SpecCopy()
Const NAME_SYNTHESE As String = "FIN EXERCICE" ' Nom de la feuille de synthèse
Const FIRST_ROW As Integer = 1 ' Numéro de la première ligne des feuilles de données
Const LAST_COLUMN As Integer = 20 ' Numéro de la dernière colonne à exporter
Dim oRangeData As Excel.Range ' Cellule comprenant les éléments de critère
Dim oSheetData As Excel.Worksheet ' Feuille contenant les données à copier
Dim oWorksheet As Excel.Worksheet ' Feuille de synthèse ("FIN EXERCICE")
Dim iLastRow As Long
Application.ScreenUpdating = False ' Désactivation du rafraichissement de l'écran
'Fixer la feuille de synthèse par son nom
Set oWorksheet = ThisWorkbook.Worksheets("FIN EXERCICE")
With oWorksheet
' Suppression des données précédentes (a desactiver si besion)
iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Rows("2:" & iLastRow + 1).Delete
End With
' Boucle sur toutes les feuilles du classeurs
On Error Resume Next
For Each oSheetData In ThisWorkbook.Worksheets
' Rajouter des noms pour exclures des feuilles
' RECAPITULATIF & MARCHES
If oSheetData.Name <> NAME_SYNTHESE And oSheetData.Name <> "RECAPITULATIF" Then
With oSheetData
If .FilterMode Then
.ShowAllData 'Affichage des données masquées
End If
' dernière ligne à partir de la colonne du critère 1
iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
'Fixe de la plage
Set oRangeData = .Range(.Cells(FIRST_ROW, 1), .Cells(iLastRow, LAST_COLUMN))
'Application des filtres sur les données (2 = colonne B & 20 = colonne T)
oRangeData.AutoFilter 2, "<>" 'Filtre pour différent du vide
oRangeData.AutoFilter 20, "=" 'Filtre pour = au vide
' Copie des cellules répondant aux critères
oRangeData.Offset(1).SpecialCells(xlCellTypeVisible).Copy
End With
With oWorksheet
iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
' La méthode pastespecial permet d'avoir accès au diffétent type
' de copie que propose excel (Ex : Coller les valeurs)
.Range("A" & iLastRow + 1).PasteSpecial xlPasteValues
End With
oSheetData.ShowAllData
End If
Next oSheetData
Application.ScreenUpdating = True
End Sub |
Partager