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
| Option Base 1
Option Explicit
Option Compare Text
Public rCell
Dim ArrayFromFollowUp()
Sub synthese_test()
Dim end_line As Range
Dim fo_test As Object
Dim fo_testColumn As String
Dim CollFromFollowUp As New Collection
Dim i As Integer
Dim FoundNA As Variant
With ThisWorkbook.Sheets("Follow_up")
On Error Resume Next
'to show all data on the sheet (if filter is on there can be a problem to make a copmplete collection)
.ShowAllData
'if you want to use this object you have to name the cell - for example fo_test
Set fo_test = .Range("fo_test")
'this is important for end line of the list. Here I get the name of the column -> "K:K"
fo_testColumn = Chr(fo_test.Column + 64) & ":" & Chr(fo_test.Column + 64)
'these two rows are for end line (end_line is a object). end_line.row is the last row of the list
Set end_line = .Range(fo_testColumn).Cells(.Range(fo_testColumn).Cells.Count)
If IsEmpty(end_line) Then Set end_line = end_line.End(xlUp)
'here I created a non duplicit collection (from the sheet follow up)
For i = fo_test.Row + 1 To end_line.Row
With .Cells(i, fo_test.Column)
If .Value <> "" Then
On Error Resume Next
CollFromFollowUp.Add .Value, CStr(.Value)
End If
End With
Next i
'here is a two dimension array
ReDim ArrayFromFollowUp(CollFromFollowUp.Count, 2)
'I filled the array from the collection
For i = 1 To CollFromFollowUp.Count
ArrayFromFollowUp(i, 1) = CollFromFollowUp(i)
Next i
'here you can sort the array - now is doesn't work right....
ShellSort ArrayFromFollowUp
'here you go through the list and try to find the values from the list in the array.
'if the value is in the array the value in second dimension I increase the value
For i = fo_test.Row + 1 To end_line.Row
FoundNA = ItemIndexInArray(ArrayFromFollowUp, .Cells(i, fo_test.Column).Value)
If FoundNA <> "N/A" Then ArrayFromFollowUp(FoundNA, 2) = ArrayFromFollowUp(FoundNA, 2) + 1
'check if it color correspond to a test which is does only on odd or even year
If .Cells(i, fo_test.Column).Interior.ColorIndex = 44 And Year(Now()) Mod 2 <> 0 Then ArrayFromFollowUp(FoundNA, 2) = ArrayFromFollowUp(FoundNA, 2) - 1
If .Cells(i, fo_test.Column).Interior.ColorIndex = 36 And Year(Now()) Mod 2 = 0 Then ArrayFromFollowUp(FoundNA, 2) = ArrayFromFollowUp(FoundNA, 2) - 1
Next i
End With
With ThisWorkbook.Sheets("synthese")
.Range("a3:b1000").ClearContents
For i = 3 To CollFromFollowUp.Count + 2
.Cells(i, 1).Value = ArrayFromFollowUp(i - 2, 1)
.Cells(i, 2).Value = ArrayFromFollowUp(i - 2, 2)
Next i
End With
End Sub
' Tri de Shell - Shell Sort
'
Public Sub ShellSort(t() As Long, _
Optional ByVal loBound As Long = -1, _
Optional ByVal upBound As Long = -1)
Dim i As Long, j As Long, h As Long, v As Long
If loBound = -1 Then
loBound = LBound(t())
End If
If upBound = -1 Then
upBound = UBound(t())
End If
h = loBound
Do
h = 3 * h + 1
Loop Until h > upBound
Do
h = h / 3
For i = h + 1 To upBound
v = t(i): j = i
Do While t(j - h) > v
t(j) = t(j - h): j = j - h
If j <= h Then
Exit Do
End If
Loop
t(j) = v
Next i
Loop Until h = loBound
End Sub
'quick algorithm for search in array (it can be a not sorted array)
Function ItemIndexInArray(Arr, Look)
Dim i
Dim k
Dim Item
ItemIndexInArray = "N/A"
i = 0
k = 0
For Each Item In Arr
i = i + 1
If Arr(i, 1) = Look Then
ItemIndexInArray = i + k
Exit For
End If
Next Item
End Function |
