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 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
| Option Explicit 'spécifie que toutes les variables doivent être déclarées
Public tb_zd As String
Public exist_dir, exist_file As String
Public tb_xl As Excel.Application
Public Source As Excel.Workbook
Public OngletSupprime, pth, tb_date, tb_an, tb_mois, pth_sortie As String
Public i, compt, compt2 As Integer
Public f As Object
Dim pole, mois, an As String
Dim msg, titre, Condition As String
Sub auto_open()
'verifie l'existence d'un bouton pour lancer la macro
'Création du bouton s'il n'existe pas
For Each f In Application.Toolbars
Application.StatusBar = f.Name
If f.Name = "Editer" Then i = 1
Next
If i <> 1 Then
Application.Toolbars.Add ("Editer")
Application.Toolbars("Editer").ToolbarButtons.Add Button:=210, Before:=2, StatusBar:="Préparation fichier TB"
'On lui affecte une macro
Application.Toolbars("Editer").ToolbarButtons(1).OnAction = ThisWorkbook!debut
Application.Toolbars("Editer").ToolbarButtons(1).Name = "TB_Extraction"
End If
With Application.Toolbars("Editer")
.Visible = True
End With
End Sub
Sub debut() 'Permet de créer le classeur final
'Renseignement des champs (pas terrible ces msgbox, à retravailler)
msg = "Ecrivez le mois recherché en majuscules :"
titre = "Choix du mois, de l'année, et du pôle"
Condition = False
mois = InputBox(msg, titre)
If mois <> "" Then
Condition = True
End If
msg = "Ecrivez l'année recherchée :"
titre = "Choix du mois, de l'année, et du pôle"
Condition = False
an = InputBox(msg, titre)
If an <> "" Then
Condition = True
End If
msg = "Ecrivez le pole recherché (4 chiffres au total) :"
titre = "Choix du mois, de l'année, et du pôle"
Condition = False
pole = InputBox(msg, titre)
If pole <> "" Then
Condition = True
End If
'mois = "AOUT"
'an = "2008"
'pole = "0010"
'initialise les fichiers et leur chemin d'accès
Application.StatusBar = "Début du module"
'fichier excel contenant la macro principale
Set Source = Workbooks("SCFI " & pole & " " & mois & " " & an & ".xls")
'repertoire de travail
pth = Workbooks("SCFI " & pole & " " & mois & " " & an & ".xls").Path + "\"
'initialisation des dates et heures
tb_an = Year(Now())
tb_mois = Month(Now())
tb_date = tb_an & "-" & tb_mois
tb_zd = "tb_zd_" & tb_date & ".xls"
'Création du répertoire de sortie
exist_dir = Dir(pth & tb_date & "_SCFI " & pole & " " & mois & " " & an, 16)
If exist_dir = "" Then 'le répertoire pour l'exercice n'existe pas
MkDir pth & tb_date & "_SCFI " & pole & " " & mois & " " & an 'on le crée
exist_dir = Dir(pth & tb_date & "_SCFI " & pole & " " & mois & " " & an, 16)
End If
'ouverture du fichier excel contenant les données
Set tb_xl = CreateObject("Excel.Application")
tb_xl.Visible = "true"
tb_xl.Workbooks.Add
'Suppression des feuilles créées par défaut : on n'en garde qu'une seule
compt = tb_xl.Sheets.Count
tb_xl.Application.DisplayAlerts = False
For i = 1 To tb_xl.Sheets.Count - 1
OngletSupprime = tb_xl.Sheets(i).Name
tb_xl.Sheets(OngletSupprime).Delete
Next i
tb_xl.Application.DisplayAlerts = True
Call tab_edit
End Sub
Sub tab_edit()
' Permet de copier les données dans le classeur initial
Application.DisplayAlerts = False
Windows("Classeur1").Activate
For i = 2 To Sheets.Count
Windows("Classeur1").Activate
Sheets(Sheets(i).Name).Select
Cells.Select
Selection.Copy
Windows("SCFI " & pole & " " & mois & " " & an & ".xls").Activate
Sheets("RECUP SCFI " & pole).Select
Cells.Select
Range("E6").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Range("E6").Select
Call Onglet
Next i
tb_xl.Application.DisplayAlerts = False
tb_xl.Sheets(1).Delete
tb_xl.Application.DisplayAlerts = True
Application.DisplayAlerts = True
Call sauvegarde
End Sub
Sub Onglet()
'Initialisation de l'onglet de page de garde
Dim NomOnglet
NomOnglet = "true"
NomOnglet = Source.Sheets(pole).Range("A1").Value
tb_xl.Sheets.Add after:=tb_xl.Sheets(1)
tb_xl.ActiveSheet.Name = [NomOnglet]
Call test
End Sub
Sub copie()
'Permet de copier le tableau de bord correspondant dans le nouveau classeur
Windows("SCFI " & pole & " " & mois & " " & an & ".xls").Activate
Sheets(pole).Select
Cells.Select
Selection.Copy
tb_xl.ActiveSheet.Range("A1").Activate
tb_xl.ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWindow.Zoom = 60
End Sub
'autre test de copie
Sub test()
Dim SHsource As Worksheet, SHcible As Worksheet, x As Integer
Dim PlageSource As Range, CelluleCible As Range, i As Integer
Set SHsource = Workbooks("SCFI " & pole & " " & mois & " " & an & ".xls").Sheets(pole) '<-- classeur source
Set SHcible = tb_xl.ActiveSheet '<-- classeur cible
Set PlageSource = SHsource.Range("A1:P52") '<-- plage de cellules à copier
Set CelluleCible = SHcible.Range("A1") '<-- destination (à partir de A1)
PlageSource.Copy CelluleCible '<-- copie de la plage
'adaptation hauteur des lignes
x = 0
For i = CelluleCible.Row To CelluleCible.Row + PlageSource.Rows.Count
x = x + 1
SHcible.Cells(i, 1).RowHeight = PlageSource.Rows(x).RowHeight
Next
'adaptation largeur des colonnes
x = 0
For i = CelluleCible.Column To CelluleCible.Column + PlageSource.Columns.Count
x = x + 1
SHcible.Cells(1, i).ColumnWidth = PlageSource.Columns(x).ColumnWidth
Next
End Sub
Sub sauvegarde()
pth_sortie = pth & exist_dir & "\" & tb_zd
Application.StatusBar = "Sortie : " & tb_zd & " " & pth_sortie
tb_xl.ActiveWorkbook.SaveAs pth_sortie
'tb_xl.ActiveWorkbook.Close
'tb_xl.Application.Quit
Application.StatusBar = "Fin de chargement"
Windows("SCFI " & pole & " " & mois & " " & an & ".xls").Application.DisplayAlerts = False
Windows("SCFI " & pole & " " & mois & " " & an & ".xls").Application.Quit
End Sub |