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
| Sub PK_Avec_UneOption()
Dim Res, Abatt, TB_Source As Range, DL As Long, VA, i As Long, j As Long, X As Integer, Tab_Pk(), TPK(), Coll_PK As New Collection, PK, nom$, L As Integer, Som As Double
Res = Application.Transpose(Array("Distance PK en Km", "PK", "Elève", "Nb élèves", "Elèves communs", "Total Km/élève", "Tarif", "Abattement", "Montant facturé", "Montant total/élève"))
Abatt = Array("10%", "23%", "37%")
Set TB_Source = Selection
With TB_Source.CurrentRegion
If Application.CountBlank(.Cells) >= 1 Then MsgBox "DONNÉES MANQUANTES" & vbCrLf & vbCrLf & "Vérifier votre tableau source !!!!!!!": Set TB_Source = Nothing: Exit Sub
DL = .Rows.Count
VA = .Value
Tab_Pk = Application.Index(VA, Evaluate("Row(2:" & DL & ")"), Array(2, 3))
For i = 2 To DL
If VA(i, 3) - VA(i, 2) <= 0 Then MsgBox "Données PK non coformes pour " & VA(i + 1, 1): Exit Sub
Next
On Error Resume Next ' --------------------------------------------------------------------------------------------------------------
For i = 1 To (DL - 1) * 2
Coll_PK.Add Application.Small(Tab_Pk, i), CStr(Application.Small(Tab_Pk, i))
If Err Then Err.Clear Else j = j + 1: ReDim Preserve TPK(1 To j): TPK(j) = Coll_PK(CStr(Application.Small(Tab_Pk, i)))
Next
Set Coll_PK = Nothing
For i = 2 To UBound(TPK)
If TPK(i) > TPK(i - 1) Then
PK = TPK(i - 1) & " à " & TPK(i)
For j = 2 To DL
If VA(j, 2) <= TPK(i - 1) And VA(j, 3) >= TPK(i) Then
Coll_PK.Add "|" & VA(j, 1) & "|", PK
If Not Err Then Err.Clear: If InStr(Coll_PK(PK), VA(j, 1) & "|") = 0 Then nom = Coll_PK(PK): Coll_PK.Remove PK: Coll_PK.Add nom & "|" & VA(j, 1) & "|", PK
End If
Next
End If
Next
On Error GoTo 0 ' -------------------------------------------------------------------------------------------------------------------
If TB_Source.Count = 1 And Not Application.Intersect(TB_Source, .Columns.Item(1)) Is Nothing Then
If Application.Match(TB_Source.Value, .Columns.Item(1), 0) > 1 Then X = Application.Match(TB_Source.Value, .Columns.Item(1), 0): i = X Else i = 2
Else
i = 2
End If
For i = i To IIf(X > 0, X, .Rows.Count)
j = 1
For Each PK In Coll_PK
Debug.Print Len(PK)
j = j + 1
If InStr(PK, "|" & VA(i, 1) & "|") > 0 Then
ReDim Preserve Res(1 To 10, 1 To UBound(Res, 2) + 1): nom = Replace(Mid("|" & VA(i, 1) & "|" & Replace(PK, "|" & VA(i, 1) & "|", ""), 2, Len(PK) - 2), "||", " | "): L = UBound(Res, 2)
Res(1, L) = TPK(j) - TPK(j - 1): Res(2, L) = TPK(j - 1) & " à " & TPK(j): Res(3, L) = VA(i, 1): Res(4, L) = Len(nom) - Len(Replace(nom, "|", "")) + 1: Res(5, L) = nom
Res(7, L) = VA(i, 4): Res(8, L) = Abatt(IIf(Res(4, L) > 2, 2, Res(4, L) - 1)): Res(9, L) = Res(1, L) * VA(i, 4) * (1 - (Val(Res(8, L)) / 100)): Som = Som + Res(9, L)
End If
Next
Res(6, L) = VA(i, 3) - VA(i, 2): Res(10, L) = Som: Som = 0
Next
Application.ScreenUpdating = False ' -------------------------------------------------------------------------------------------------------------------
With .Offset(, .Columns.Count + 3).Resize(1, 1)
.CurrentRegion.Clear
.Resize(UBound(Res, 2), UBound(Res)) = Application.Transpose(Res)
With .CurrentRegion
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .Columns.AutoFit
New_inter_Coul 2, .Cells, 3
.Borders.Value = 1
End With
End With
Application.ScreenUpdating = True ' -------------------------------------------------------------------------------------------------------------------
End With
End Sub |
Envoyé par Klin89
Répondre avec citation
ne t'inquiète pas je ne suis pas aveugle, d'ailleurs je t'avais fait un Edit 2 avant que tu posts 
=> 
pour le bug - je vais t'appeler The hunter of bugs 
et 
pour la chasse aux bugs 
Partager