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
| Option Base 1
Option Explicit
Sub ECM()
'
'Déclaration des variables
'
Dim derniere_ligne As Long
Dim Tab_SCHEMA() As Variant
Dim Tab_ID() As Variant
Dim str As String
Dim i As Long
Dim classeur As String
Dim statusBarInitial As Long
'
'Enlever le filtre des cellules B2 à K2
'Le fichier doit impérativement disposer des filtres à l'ouverture.
'
Range("B2:K2").Select
Selection.AutoFilter
'
'Effacer la zone B3 à K (dernière ligne colonne C : valeur se trouvant en A1)
'
Range("B3:K" & [A1]).ClearContents
'
'Dans l'onglet "ECM" effacer le contenu de la cellule A7
'
Range("A7").Select
Selection.ClearContents
'
'Ecrire dans la cellule A7 la date du jour. Ceci permettra de garder une trace de
'la date de mise à jour du fichier
'
ThisWorkbook.Worksheets("ECM").Range("A7").Value = Now()
'
Range("A2").Select
'
MsgBox ("Previous values cleared")
'
'La data base ECM a t-elle déja été nettoyée ?
'
If MsgBox("Has the ECM data base already been cleaned ?", vbYesNo, "Confirmation Request") = vbNo Then
'
classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
Workbooks.Open classeur
Sheets("schema.xml_temporary").Activate
'
MsgBox ("WARNING : The cleaning of the file will start" & Chr(10) & Chr(10) & "Thank you for waiting")
'
'Recherche du numéro de la dernière ligne
'
derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
MsgBox ("Derniere ligne = ") & derniere_ligne
'
'Suppression des formules éventuelles contenues dans ce fichier (on remplace les "=" par des "-")
'
Range("A2:AY" & derniere_ligne).Select
Selection.Replace What:="=", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'
Range("A2").Select
'
MsgBox ("The ECM Data base has been cleaned" & Chr(10) & Chr(10) & "WARNING : The initial file will be updated !!")
'
'Enregistrement de la data base ECM (ATTENTION : l'ancienne version est écrasée)
'
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="schema.xml_temporary.xlsx"
Application.DisplayAlerts = True 'Remettre absolument ensuite
MsgBox ("The ECM Data base has been cleaned and saved (overwritten file)" & Chr(10) & Chr(10) & "The storage of data will begin")
Else
classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
Workbooks.Open classeur
Sheets("schema.xml_temporary").Activate
derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
MsgBox ("Derniere ligne = ") & derniere_ligne
MsgBox ("The storage of data will begin")
End If
'
'La ligne d'instruction ci-dessous suffit à elle seule pour remplir le tableau !!
'La zone mise en mémoire part de la 2ème ligne --> Range("A2") jusqu'à la ligne "derniere_ligne - 1"
'Le tableau contient 51 colonnes et "derniere_ligne - 1" lignes
'
Tab_SCHEMA = Range("A2").Resize(derniere_ligne - 1, 51).Value
'
MsgBox ("Data storage of 'schema.xml_temporary.xlsx' file is complete.")
'
'Pour debugage uniquement
'
'MsgBox ("1 2 = ") & Tab_SCHEMA(1, 2)
'MsgBox ("1 51 = ") & Tab_SCHEMA(1, 51)
'MsgBox ("399458 2 = ") & Tab_SCHEMA(399458, 2)
'MsgBox ("399458 51 = ") & Tab_SCHEMA(399458, 51)
'MsgBox ("399458 49 = ") & Tab_SCHEMA(399458, 49)
'
'Fermer le classeur actif
'
ActiveWorkbook.Close SaveChanges:=False
'
'Activation du fichier "FOLLOW_UP_TEST.xlsm", on se place dans l'onglet "ECM"
'
Windows("FOLLOW_UP_TEST.xlsm").Activate
Sheets("ECM").Activate
'
MsgBox ("Extraction of ID from 'Document title' will begin")
'
'Ci-dessous, mis en commentaire car ralentit beaucoup trop le processus
'statusBarInitial = Application.DisplayStatusBar
'Application.DisplayStatusBar = True
'
'Extraction de l'ID de tous les "Document title"
'
ReDim Tab_ID(1 To UBound(Tab_SCHEMA), 10)
For i = 1 To derniere_ligne - 1 'meme si c'est cohérent pourquoi ne boucle tu pas sur TAB_SCHEMA plutôt ?????????
'
'Ci-dessous, mis en commentaire car ralentit beaucoup trop le processus
'Application.StatusBar = "Calcul en cours... " & i & " / " & derniere_ligne - 1
'
str = Tab_SCHEMA(i, 2)
Tab_ID(i, 1) = ExtraireID(str)
Tab_ID(i, 2) = Tab_SCHEMA(i, 2)
Tab_ID(i, 3) = Tab_SCHEMA(i, 3)
Tab_ID(i, 4) = Tab_SCHEMA(i, 4)
Tab_ID(i, 5) = Tab_SCHEMA(i, 5)
Tab_ID(i, 6) = Tab_SCHEMA(i, 22)
Tab_ID(i, 7) = Tab_SCHEMA(i, 23)
Tab_ID(i, 8) = Tab_SCHEMA(i, 24)
Tab_ID(i, 9) = Tab_SCHEMA(i, 25)
Tab_ID(i, 10) = Tab_SCHEMA(i, 36)
Next
'
'
'Ecriture des résultats dans l'onglet "ECM"
'
'For i = 1 To derniere_ligne - 1
'Cells(i + 2, 2) = Tab_ID(i, 1)
'Cells(i + 2, 3) = Tab_ID(i, 2)
'Cells(i + 2, 4) = Tab_ID(i, 3)
'Cells(i + 2, 5) = Tab_ID(i, 4)
'Cells(i + 2, 6) = Tab_ID(i, 5)
'Cells(i + 2, 7) = Tab_ID(i, 6)
'Cells(i + 2, 8) = Tab_ID(i, 7)
'Cells(i + 2, 9) = Tab_ID(i, 8)
'Cells(i + 2, 10) = Tab_ID(i, 9)
'Cells(i + 2, 11) = Tab_ID(i, 10)
'Next
'
'Explication de la ligne d'instruction plus bas (remplace la boucle juste au dessus):
'Sheets("ECM").Cells(ligne3, col2).redimensionnée au (nombre de lignes de (Tab_ID) et nombre de col de (Tab_ID, 2)).value= tout le Tab_ID
'
Sheets("ECM").Cells(3, 2).Resize(UBound(Tab_ID), UBound(Tab_ID, 2)).Value = Tab_ID
'
Range("A2").Select
'
'Ajustement automatique de la largeur des colonnes (colonnes B à K)
'
Columns("B:K").Select
Columns("B:K").EntireColumn.AutoFit
'
'Création d'un filtre de la cellule B2 à K2
'
Range("B2:K2").Select
Selection.AutoFilter
'
'Affichage de tous les ID sauf si la cellule de la colonne B est vide
'
ActiveWorkbook.Worksheets("ECM").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ECM").AutoFilter.Sort.SortFields.Add Key:=Range( _
"B2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("ECM").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
'Cette ligne d'instruction supprime les données pour lesquelles la colonne B est vide
'
ActiveSheet.Range("$B$2:$K$" & [A1]).AutoFilter Field:=1, Criteria1:="<>"
'
Range("A2").Select
'
MsgBox ("Process completed")
'
End Sub
Function ExtraireID(s As String) As String
Dim id As String
id = Mid("IDxxxx" & s, InStrRev("IDxxxx" & s, "ID") + 2, 4) 'si pas d'ID on obtient xxxx
If Format(Val(id), "0000") = id Then ExtraireID = id Else ExtraireID = ""
End Function |