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
| Dim montabval()
Sub compilatb2006()
ThisWorkbook.Sheets.Add Before:=Worksheets(1) 'choisi la position de ta feuille
ActiveSheet.Name = "ATB2006"
Range("a1:j1") = Array("code", "sect_act", "Nb_hosp", "Nb_AD", "Nblits", "mol_G", "mol_DDD", "DCI", "ATC", "DDD")
' j'ai donc x données composée de 10 colonnes a récuperer sur chaque feuille
For X = 3 To Sheets.Count
' en premier tester la cellule ("11,3")
If IsNumeric(Sheets(X).Cells(11, 3)) And Sheets(X).Cells(11, 3) <> "" Then
'd'abord les données constantes
code = Sheets(X).Cells(7, 2)
sect_act = Sheets(X).Name
Nb_hosp = Sheets(X).Cells(11, 3)
Nb_AD = Sheets(X).Cells(12, 3)
Nblits = Sheets(X).Cells(13, 3)
DCI = "DCI"
ATC = "ATC"
DDD = "DDD"
' ensuite les données dynamiques
C = Array("", 6, 8)
L = Array("", 31, 40, 51, 57, 59, 70, 79, 83, 87, 89, 92, 97, 102, 107, 112, 123, 127, 132, 140, _
146, 148, 151, 158, 164, 171, 175, 178, 186, 192, 200, 205, 208, 216, 219, 224, 227, 236, 238, 240, 244, _
250, 254, 257, 260, 264, 266, 276, 278, 281, 298, 305, 309, 311, 316, 324, 330, 332, 339, 343, 345, _
352, 355, 360, 365, 367, 376, 382, 387, 389, 396, 398, 401, 409, 411, 415, 417, 419, 423, 427, 433, _
436, 442, 444, 446, 454, 463, 468, 475, 480, 485, 487, 490, 499, 503, 505, 511, 515, 518, 520, 523, 529)
ReDim Preserve montabval(nbligne + UBound(L))
For y = LBound(L) + 1 To UBound(L)
mol_G = Sheets(X).Cells(L(y), C(1))
mol_DDD = Sheets(X).Cells(L(y), C(2))
montabval(nbligne + y) = Array(code, sect_act, Nb_hosp, Nb_AD, Nblits, mol_G, mol_DDD, DCI, ATC, DDD)
Next y
nbligne = nbligne + UBound(L)
End If
Next X ''''
' ensuite on écris le tout
For z = LBound(montabval) + 1 To UBound(montabval)
Zonedecriture = "a" & z + 1 & ":j" & z + 1 'determine la taille des lignes ou ecrire le nouveau tableau
Range(Zonedecriture) = montabval(z) 'écriture
Next z
End Sub |