VBA - DO LOOP - Recherche une valeur mentionnée plusieurs fois et trouver son adresse

**TonyRc** · 22/07/2014, 08h30

Bonjour a tous,

Voici mon probleme, je programme excel afin d'enregistrer l'ensemble des flux logistiques sur un type de camion precis. Et d'emettre a terme un rapport.

Actuellement, un camion peut faire plusieurs tournees dans la journee. Enregistrer la premier tournee ne me pose aucun probleme. [Voir code couleur]
La seconde et les successives sont plus difficiles... Je cherche et je tourne en ronds avec "DO ... LOOP"

Est-ce qu'une personne pourrait m'expliquer?

Merci, Tonyrc

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Report_data()
''''''''''''''''''''''''''
'''   Data Recording   '''
''''''''''''''''''''''''''
Sheets("Working_table").Select
Range(Cells(6, 5), Cells(100, 294)).Select
Selection.ClearContents
 
 
''''''''''''''''''''''''''
'''Pull out form Truck available data
Nblines_bdd = WorksheetFunction.CountA(Sheets("database").Range("A:A"))
Nblines_table = WorksheetFunction.CountA(Sheets("Table").Range("A:A"))
 
 
For alpha = 1 To Nblines_table
 
Sheets("Table").Select
truck = Cells(2 + alpha, 2)
count_truck = Sheets("Working_table").Cells(5 + alpha, 4)
 
Set ws = Sheets("Database")
ws.Select
 
Set pl = ws.Range("d2:d" & Nblines_bdd)
Set r = pl.Find(what:=truck, lookAt:=xlWhole, SearchDirection:=xlNext)
 
        If Not r Is Nothing Then
        pa = r.Address
        sr1 = Cells(Range(pa).Row, 1)
 
'''' PROBLEME ICI ??? 
      '  Do Until r Is Nothing
 
       ' Loop
 
 
 
RPC_Dep = Cells(Range(pa).Row, 15)
RPC_Arr = Cells(Range(pa).Row, 16)
Site_Dep = Cells(Range(pa).Row, 17)
Site_Arr = Cells(Range(pa).Row, 18)
 
 
''''''''''''''''''''''''
''' Paste from above lookup concern data
Sheets("Working_table").Select
 
For time_col = 0 To 288
        Data = Cells(5, 5 + time_col)
 
        If Data >= RPC_Dep And Data < RPC_Arr Then
        Cells(5 + alpha, 5 + time_col) = 1
        End If
 
        If Data >= RPC_Arr And Data < Site_Dep Then
        Cells(5 + alpha, 5 + time_col) = 2
        End If
 
        If Data >= Site_Dep And Data < Site_Arr Then
        Cells(5 + alpha, 5 + time_col) = 3
        End If
Next time_col
 
    End If
 
Next alpha
 
End Sub

Ceci fonctionne avec deux tournees de camions identique dans la journee mais pas plus ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Report_data()
''''''''''''''''''''''''''
'''   Data Recording   '''
''''''''''''''''''''''''''
 
Dim Nblines_bdd As Integer, Nblines_table As Integer, alpha As Integer, count_Truck As Integer, time_col As Integer
Dim pl As Variant, r As Variant, ra As Variant
Dim truck As String
Dim pa As String, pb As String, pc As String
Dim RPC_Dep As Integer, RPC_Arr As Integer, Site_Dep As Integer, site_arr As Integer
 
 
''' Clean dashboard in working sheet
Sheets("Working_table").Select
Range(Cells(6, 5), Cells(100, 294)).Select
Selection.ClearContents
 
 
''''''''''''''''''''''''''
'''Pull out from Database
''''''''''''''''''''''''''
Nblines_bdd = WorksheetFunction.CountA(Sheets("database").Range("A:A"))
Nblines_table = WorksheetFunction.CountA(Sheets("Table").Range("A:A"))
 
 
For alpha = 1 To Nblines_table
 
''' Find the concern selected truck from TABLE
Sheets("Table").Select
truck = Cells(2 + alpha, 2)
count_Truck = Sheets("Working_table").Cells(5 + alpha, 4)
 
Set ws = Sheets("Database")
ws.Select
 
Set pl = ws.Range("d2:d" & Nblines_bdd)
Set r = pl.Find(what:=truck, lookAt:=xlWhole, SearchDirection:=xlNext)
n = 0
        If Not r Is Nothing Then
        pa = r.Address
        sr1 = Cells(Range(pa).Row, 1)
 
''' Record his timing in min
        RPC_Dep = Cells(Range(pa).Row, 15)
        RPC_Arr = Cells(Range(pa).Row, 16)
        Site_Dep = Cells(Range(pa).Row, 17)
        site_arr = Cells(Range(pa).Row, 18)
 
 
''' Color range
        Sheets("Working_table").Select
 
For time_col = 0 To 288
        Data = Cells(5, 5 + time_col)
 
        If Data >= RPC_Dep And Data < RPC_Arr Then
        Cells(5 + alpha, 5 + time_col) = 1
        End If
 
        If Data >= RPC_Arr And Data < Site_Dep Then
        Cells(5 + alpha, 5 + time_col) = 2
        End If
 
        If Data >= Site_Dep And Data < site_arr Then
        Cells(5 + alpha, 5 + time_col) = 3
        End If
Next time_col
 
 
''''''''''''''''''''''''''
''' Second loop and others
''''''''''''''''''''''''''
ws.Select
        Do
 
        Set ra = pl.FindNext(r)
        pb = ra.Address
        sr2 = Cells(Range(pb).Row, 1)
 
 
 
        RPC_Dep = Cells(Range(pb).Row, 15)
        RPC_Arr = Cells(Range(pb).Row, 16)
        Site_Dep = Cells(Range(pb).Row, 17)
        site_arr = Cells(Range(pb).Row, 18)
 
''''''''''''''''''''''''
''' Color range
        Sheets("Working_table").Select
 
For time_col = 0 To 288
        Data = Cells(5, 5 + time_col)
 
        If Data >= RPC_Dep And Data < RPC_Arr Then
        Cells(5 + alpha, 5 + time_col) = 1
        End If
 
        If Data >= RPC_Arr And Data < Site_Dep Then
        Cells(5 + alpha, 5 + time_col) = 2
        End If
 
        If Data >= Site_Dep And Data < site_arr Then
        Cells(5 + alpha, 5 + time_col) = 3
        End If
Next time_col
 
        Loop While Not r Is Nothing And r.Address <> pa   
 
 
    End If
 
Next alpha
 
End Sub

**TonyRc** · 22/07/2014, 10h27

J'ai trouve la solution!

Un peu de publicite pour ce site web qui m'a fourni la cle de l'enigme! Merci a tous!

http://www.cpearson.com/excel/findall.aspx

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Record_Data()
 
 
Dim Foundcell As Range
Dim Lastcell As Range
Dim FirstAddr As String, pa As String, pb As String
Dim alpha As Integer, Nblines_bdd As Integer, nblines_table As Integer
Dim Truck As String
 
''' Clean dashboard in working sheet
Sheets("Working_table").Select
Range(Cells(6, 5), Cells(100, 294)).Select
Selection.ClearContents
 
Nblines_bdd = WorksheetFunction.CountA(Sheets("Database").Range("A:A"))
nblines_table = WorksheetFunction.CountA(Sheets("Table").Range("A:A"))
 
For alpha = 1 To nblines_table
 
Sheets("table").Select
Truck = Cells(alpha + 2, 2)
 
Set ws = Sheets("Database")
ws.Select
 
        ''' Define Last cell data
        With Range("d2:d" & Nblines_bdd)
        Set Lastcell = .Cells(.Cells.Count)
        End With
 
 
        Set Foundcell = Range("d2:d" & Nblines_bdd).Find(what:=Truck, after:=Lastcell)
 
        'Set the address of the First Foundcell
        If Not Foundcell Is Nothing Then
        FirstAddr = Foundcell.Address
        pa = FirstAddr
 
''' Record his timing in min
        RPC_Dep = Cells(Range(pa).Row, 15)
        RPC_Arr = Cells(Range(pa).Row, 16)
        Site_Dep = Cells(Range(pa).Row, 17)
        site_arr = Cells(Range(pa).Row, 18)
 
''' Color range
        Sheets("Working_table").Select
 
For time_col = 0 To 288
        Data = Cells(5, 5 + time_col)
 
        If Data >= RPC_Dep And Data < RPC_Arr Then
        Cells(5 + alpha, 5 + time_col) = 1
        End If
 
        If Data >= RPC_Arr And Data < Site_Dep Then
        Cells(5 + alpha, 5 + time_col) = 2
        End If
 
        If Data >= Site_Dep And Data < site_arr Then
        Cells(5 + alpha, 5 + time_col) = 3
        End If
Next time_col
ws.Select
 
        End If
 
        ' Loop data
        Do Until Foundcell Is Nothing
           Debug.Print Foundcell.Address
 
           Set Foundcell = Range("d2:d" & Nblines_bdd).FindNext(after:=Foundcell)
                pb = Foundcell.Address
 
                If pb = FirstAddr Then
                Exit Do
                Else:
 
''' Record his timing in min
        RPC_Dep = Cells(Range(pb).Row, 15)
        RPC_Arr = Cells(Range(pb).Row, 16)
        Site_Dep = Cells(Range(pb).Row, 17)
        site_arr = Cells(Range(pb).Row, 18)
 
''' Color range
        Sheets("Working_table").Select
 
For time_col = 0 To 288
        Data = Cells(5, 5 + time_col)
 
        If Data >= RPC_Dep And Data < RPC_Arr Then
        Cells(5 + alpha, 5 + time_col) = 1
        End If
 
        If Data >= RPC_Arr And Data < Site_Dep Then
        Cells(5 + alpha, 5 + time_col) = 2
        End If
 
        If Data >= Site_Dep And Data < site_arr Then
        Cells(5 + alpha, 5 + time_col) = 3
        End If
Next time_col
ws.Select
 
                End If
        Loop
 
Next alpha
 
End Sub