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
| 'Nom de la macro
Sub save()
'Déclaration des variables
Dim test As Range
Dim cell_des As Range
Dim table() As String
Dim j As Integer
'On travaille dans la feuille "contacts_archiv"
With Worksheets("contacts_archiv")
'On set test sur la cellule "A1"
Set test = .Range("A1")
'On boucle de 1 au nombre de lignes qu'on trouve dans la colonne 1 (ou A) - 1
For i = 1 To .Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row - 1
'On redimentionne notre tableau en effacant toutes les données comprises dedant
ReDim table(1 To 1)
'Le test se situe ici : si test.Offset(i, 0) (c-a-d test avec un offset de i ligne(s) ) est différent de la ligne suivante alors...
If test.Offset(i, 0) <> test.Offset(i - 1, 0) Then
'On set j à 0
j = 0
'Et on execute jusqu'à ce que test.Offset(i + j, 0) est différent de test.Offset(i, 0) (voir "Loop Until") le code suivant :
Do
'On redimensionne notre tableau en préservant son contenu
ReDim Preserve table(1 To j + 1)
'On ajoute à notre tableau la valeur contenu à droite de test test.Offset(i + j, 0) c'est à dire la colonne "Infos"
table(j + 1) = test.Offset(i + j, 1).Value
'On incrémente j
j = j + 1
Loop Until test.Offset(i + j, 0).Value <> test.Offset(i, 0).Value
'Enfin, on appelle la fonction "AddNewWorkbook" lorsque le tableau est "plein" avec les paramètres "test.Offset(i, 0)" et "table"
AddNewWorkbook test.Offset(i, 0), table
End If
Next i
End With
End Sub
'La fonction "AddNewWorkbook" :
Function AddNewWorkbook(rng As Range, table() As String)
'Déclaration des variables
Dim xlApp As Excel.Application
Dim workb As Workbook
Dim xlSheet As Excel.Worksheet
Dim strt As Integer
Dim cell_des As Range
Dim msg As String
'Création du fichier excel
Set xlApp = CreateObject("Excel.Application")
xlApp.SheetsInNewWorkbook = 1
Set workb = Application.Workbooks.Add
'Ici on sauvegarde le fichier à la localisation qui se trouve dans la colonne C. (C'est ce que j'avais compris...)
workb.SaveAs Filename:=rng.Offset(0, 2).Value
xlApp.Visible = True
'On assigne à ce nouveau fichier un seul onglet...
Set xlSheet = workb.Worksheets(1)
'...qu'on nomme comme la colonne A.
xlSheet.name = rng.Value
'Avec ce nouveau classeur
With ActiveWorkbook.Worksheets(rng.Value)
'On insère les titres
Set cell_des = .Range("A1")
cell_des = "Contact"
cell_des.Font.Bold = True
cell_des.Offset(0, 1) = "Infos"
cell_des.Offset(0, 1).Font.Bold = True
'Et on place toutes les infos qu'on avait dans la colonne Infos
For i = 1 To UBound(table)
cell_des.Offset(i, 0) = rng.Value
cell_des.Offset(i, 1) = table(i)
Next i
End With
'On sauvegarde le fichier et on le ferme.
ActiveWorkbook.Close SaveChanges:=True
'xlApp.Quit
End Function |
