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
|
Option Explicit
Sub traitementPubPriv()
'liste les colonnes
If listeColEnTete = False Then
MsgBox "Erreur dans le nom des intCols, Arrêt de la routine"
Exit Sub
End If
If CreateSheet("Public") <> "Public" Then MsgBox "Proplème création feuille " & "Public": GoTo erreur
If CreateSheet("Private") <> "Private" Then MsgBox "Proplème création feuille " & "Private": GoTo erreur
FillPubPriSheet ("Public") 'traite la feuille Public
FillPubPriSheet ("Private") 'traite la feuille Private
erreur:
Set colEntete = Nothing
End Sub
Function FillPubPriSheet(Pub_Pri As String)
Dim wshTable As Worksheet, wshPubPri As Worksheet 'les feuilles
Dim PrStat() As Variant, Complet() As Variant, Societes As Variant 'les tableaux
Dim lngB1 As Long, intb2 As Integer, rngb3 As Range 'Les boucles
Dim strTxt As String
Dim lngUbound As Long 'taille tableau
Dim dblTotal As Double, dblSomme As Double 'Calcul
Dim intCol As Integer, lngRow As Long, rngPlage As Range 'reference aux cellules
Dim rngFind As Range 'pour la recherche
Set wshTable = Worksheets("Table")
Set wshPubPri = Worksheets(Pub_Pri)
'A décommenter pour vider la feuille avant le traitement
wshPubPri.Cells.Delete Shift:=xlUp
'Liste les propiétaires public ou private
lngUbound = 0
For Each rngb3 In wshTable.Range("A2:A" & wshTable.Cells(Rows.Count, 1).End(xlUp).Row)
If UCase(rngb3.Offset(0, 1)) = UCase(Pub_Pri) Then
ReDim Preserve PrStat(lngUbound)
PrStat(lngUbound) = Trim(rngb3.Value)
lngUbound = lngUbound + 1
End If
Next
With Worksheets("Projects")
'recherche des montants à utiliser
dblTotal = 0: lngUbound = 0 ':dblSomme = 0
ReDim Complet(2, lngUbound)
'boucle dans la feuille Projects
For Each rngb3 In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
'Boucle dans le tableau pour connaitre le status de la ligne
For lngB1 = LBound(PrStat) To UBound(PrStat)
'si c'est le status cherché
If InStr(1, UCase(rngb3), UCase(PrStat(lngB1))) Then
ReDim Preserve Complet(2, lngUbound)
'0 = Nom du projet
Complet(0, lngUbound) = rngb3.Value
'1 = Valeur du projet
If UCase(Trim(.Cells(rngb3.Row, colEntete(ProProjectStat)))) = "COMPLETE" Then
Complet(1, lngUbound) = .Cells(rngb3.Row, colEntete(ProContracValu)).Value
Else
Complet(1, lngUbound) = .Cells(rngb3.Row, colEntete(ProBudjectValu)).Value
End If
dblTotal = dblTotal + CDbl(Complet(1, lngUbound))
'2 = Liste des entreprises
Complet(2, lngUbound) = .Cells(rngb3.Row, colEntete(ProEpcContract)).Value
'3 = N° de la ligne
'Complet(3, lngUbound) = rngb3.Row
lngUbound = lngUbound + 1
Exit For
End If
Next
Next
End With
Complet = TriTabEnBulle(Complet)
dblSomme = 0
With wshPubPri
'boucle dans le tableau précédemment créé
For lngB1 = UBound(Complet, 2) To LBound(Complet, 2) Step -1
'somme pour vérifier les 60%
dblSomme = dblSomme + Complet(1, lngB1)
'cherche dans quel colonne écrire
intCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
'écriture du projet
.Cells(1, intCol) = Complet(0, lngB1)
'écriture du montant
.Cells(2, intCol) = Complet(1, lngB1)
'Ecriture des entreprise
'boucle dans les différents Entreprises de la cellule
For intb2 = 0 To UBound(Split(Complet(2, lngB1), "*"))
'Est-ce que l'entreprise à déja été écrite dans la Feuille Public
Set rngPlage = .Range("A3:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
strTxt = Trim(Split(Complet(2, lngB1), "*")(intb2))
Set rngFind = rngPlage.Find(strTxt, LookIn:=xlValues, lookat:=xlWhole)
'oui
If Not rngFind Is Nothing Then
'oui -> noter la ligne
lngRow = rngFind.Row
Else
'non -> l'écrire et noter la ligne
lngRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
lngRow = IIf(lngRow < 3, 3, lngRow)
.Cells(lngRow, 1) = strTxt
End If
'passer la cellule de croisement entreprise / projet en jaune
.Cells(lngRow, intCol).Interior.ColorIndex = 6
Next
If dblSomme > dblTotal * 0.6 Then Exit For
Next
.Cells.EntireColumn.AutoFit
End With
'pour terminer proprement
Set rngFind = Nothing: Set rngPlage = Nothing
Set wshTable = Nothing: Set wshPubPri = Nothing
End Function
'Tri spécifique d'un tableau(0 to 2, 0 to NbLigne)
Function TriTabEnBulle(tabTri As Variant) As Variant
Dim intI As Integer, intJ As Integer, intK As Integer, varTmp(2) As Variant
For intI = LBound(tabTri, 2) To UBound(tabTri, 2)
intJ = intI
For intK = intJ + 1 To UBound(tabTri, 2)
If tabTri(1, intK) <= tabTri(1, intJ) Then intJ = intK
Next intK
If intI <> intJ Then
varTmp(0) = tabTri(0, intJ): varTmp(1) = tabTri(1, intJ): varTmp(2) = tabTri(2, intJ)
tabTri(0, intJ) = tabTri(0, intI): tabTri(1, intJ) = tabTri(1, intI): tabTri(2, intJ) = tabTri(2, intI)
tabTri(0, intI) = varTmp(0): tabTri(1, intI) = varTmp(1): tabTri(2, intI) = varTmp(2)
End If
Next intI
TriTabEnBulle = tabTri
End Function |
Reordonner un tableau excel avec macro
Répondre avec citation
il n'y a plus que les titres des colonnes qui sont identiques 
Envoyé par zyhack
..quand c'est le cas !
Partager