la derniere partie de ma macro ne donne rien

**arctica** · 07/10/2009, 12h32

Bonjours à tous

debutant en vba j'ai grace à vous créer une macro qui doit mettre en page calculer des données et transferer des données vers des feuilles cibles malheureusement la derniere partie sensée copier les lignes critere tansporteur avec délai ne donne aucun résultat car avec critere pays et transporteur seul fonctionne pourriez vous m'aider et pour ma gouverne me dire pourquoi cela ne marche pas car le code uniquement avec les feuilles ciblées marche (des qu'il y a les autres feuilles donc pays cela ne colle pas ) je joins un exemple de fichier à traiter avec le code ci joint
merci pour votre aide

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
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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
Sub amelioration()
'reprise de mise_en_page
        Range("A:A,C:C,D:D,E:E,M:M,S:AK").Delete Shift:=xlToLeft
        Columns("E:E").Insert Shift:=xlToRight
        Range("E1").FormulaR1C1 = "=INT(RC[1]/1000)"
         Range("E1").AutoFill Destination:=Range("E1:E10000"), Type:=xlFillDefault
        Columns("A:A").Insert Shift:=xlToRight
        Rows("1:2").Insert Shift:=xlDown
'edification d'un tableau(plage + nommer plage)
    Dim ListSh() As Variant
'On inscrit les noms dans un tableau
         ListSh = Array("d24", "d48", "j24", "j48", "j72", "m24", "m48", "m72", "mon96", "tnt", "tof", _
        "Autriche", "Allemagne", "Italie", "Suisse", "CZ", "DK", "Pologne", "ferié", "carte des délais")
'on boucle du plus petit indice au plus grand indice du tableau
        For i = LBound(ListSh) To UBound(ListSh)
'on cré la feuille après la dernière feuille existante
        Sheets.Add after:=Sheets(Sheets.Count)
'on nomme la nouvelle feuille
         ActiveSheet.Name = ListSh(i)
    Next
    For i = Cells(65000, 10).End(xlUp).Row To 1 Step -1 'boucle de la dernière ligne colonne J à la première
    If Cells(i, 10) Like "GLS" Then Rows(i).Delete 'supprime la ligne si elle contient "GLS"
    Next
 
        Sheets("carte des délais").Activate
 
        [E3:E42] = Application.Transpose(Array(4, 5, 6, 9, 12, 13, 14, 19, 22, 23, 27, 29, 30, 31, 33, 34, _
        35, 37, 44, 46, 47, 48, 49, 50, 53, 56, 61, 65, 66, 72, 76, 79, 81, 82, 83, 84, 85, 86, 87, 89))
        ActiveWorkbook.Names.Add Name:="j48hr", RefersTo:=[E3:E42]
 
        [B3:B27] = Application.Transpose(Array(2, 3, 8, 11, 25, 38, 39, 42, 51, 54, 55, 57, 60, 62, 67, 68, _
        69, 70, 77, 88, 90, 92, 93, 94, 95))
        ActiveWorkbook.Names.Add Name:="d24hr", RefersTo:=[B3:B27]
 
        [C3:C67] = Application.Transpose(Array(1, 4, 5, 6, 7, 9, 10, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, _
        22, 23, 24, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 40, 41, 43, 44, 45, 46, 47, 48, 49, 50, 53, 56, 61, _
        63, 64, 65, 66, 72, 73, 74, 75, 76, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 91))
        ActiveWorkbook.Names.Add Name:="d48hr", RefersTo:=[C3:C67]
 
        [D3:D13] = Application.Transpose(Array(1, 2, 3, 8, 26, 52, 58, 59, 71, 78, 79))
        ActiveWorkbook.Names.Add Name:="j24hr", RefersTo:=[D3:D13]
 
        [F3:F6] = Application.Transpose(Array(24, 32, 40, 64))
        ActiveWorkbook.Names.Add Name:="j72hr", RefersTo:=[F3:F6]
 
        [G3:G6] = Application.Transpose(Array(57, 67, 68, 90))
        ActiveWorkbook.Names.Add Name:="m24hr", RefersTo:=[G3:G6]
 
        [H3:H52] = Application.Transpose(Array(1, 2, 3, 7, 8, 10, 13, 14, 18, 21, 23, 25, 26, 27, 28, 30, 36, _
        38, 39, 42, 43, 45, 51, 52, 54, 55, 58, 59, 60, 61, 62, 63, 69, 70, 71, 73, 74, 75, 76, 77, 78, 80, 84, 88, 89, _
        91, 92, 93, 94, 95))
        ActiveWorkbook.Names.Add Name:="m48hr", RefersTo:=[H3:H52]
 
        [I3:I42] = Application.Transpose(Array(4, 5, 6, 9, 11, 12, 15, 16, 17, 19, 22, 24, 29, 31, 32, 33, _
        34, 35, 37, 40, 41, 44, 46, 47, 48, 49, 50, 53, 56, 64, 65, 66, 72, 79, 81, 82, 83, 85, 86, 87, 2, 3, 8, 26, _
        52, 58, 59, 71, 78, 79))
        ActiveWorkbook.Names.Add Name:="m72hr", RefersTo:=[I3:I42]
 
        [j3] = Application.Transpose(Array(20))
        ActiveWorkbook.Names.Add Name:="m96hr", RefersTo:=[j3]
 
        [j3:j3] = Application.Transpose(Array(20))
        ActiveWorkbook.Names.Add Name:="m96hr", RefersTo:=[j3:j13]
 
        Sheets("ferié").Activate
 
        [b3:b14] = Application.Transpose(Array("1/1/2009", "13/4/2009", "1/5/2009", "8/5/2009", "21/5/2009", "1/6/2009", _
        "11/6/2009", "14/7/2009", "15/8/2009", "1/11/2009", "11/11/2009", "25/12/2009"))
        ActiveWorkbook.Names.Add Name:="France", RefersTo:=[b3:b14]
 
        [c3:c14] = Application.Transpose(Array("1/1/2009", "6/1/2009", "13/4/2009", "1/5/2009", "21/5/2009", "1/6/2009", _
        "11/6/2009", "15/8/2009", "26/10/2009", "1/11/2009", "8/12/2009", "25/12/2009", "26/12/2009"))
        ActiveWorkbook.Names.Add Name:="Autriche", RefersTo:=[c3:c14]
 
        [d3:d12] = Application.Transpose(Array("1/1/2009", "13/4/2009", "1/5/2009", "3/5/2009", "11/6/2009", _
        "15/8/2009", "1/11/2009", "11/11/2009", "25/12/2009", "26/12/2009"))
        ActiveWorkbook.Names.Add Name:="Pologne", RefersTo:=[d3:d12]
 
 
        [e3:e13] = Application.Transpose(Array("1/1/2009", "13/4/2009", "1/5/2009", "5/7/2009", "6/7/2009", "28/9/2009", _
        "28/10/2009", "17/11/2009", "24/12/2009", "25/12/2009", "26/12/2009"))
        ActiveWorkbook.Names.Add Name:="Tscheco", RefersTo:=[e3:e13]
 
        [F3:F12] = Application.Transpose(Array("1/1/2009", "6/1/2009", "10/4/2009", "13/4/2009", "1/5/2009", "21/5/2009", _
        "1/6/2009", "1/8/2009", "25/12/2009", "26/12/2009"))
        ActiveWorkbook.Names.Add Name:="Suisse", RefersTo:=[F3:F12]
 
        [G3:G12] = Application.Transpose(Array("1/1/2009", "6/1/2009", "10/4/2009", "13/4/ 2009", "1/5/2009", "21/5/2009", _
        "1/6/2009", "3/10/2009", "25/12/2009", "26/12/2009"))
        ActiveWorkbook.Names.Add Name:="Allemagne", RefersTo:=[G3:G12]
 
        [H3:H12] = Application.Transpose(Array("1/1/2009", "9/4/2009", "10/4/2009", "13/4/2009", " 8/5/2009", "21/5/2009", _
        "1/6/2009", " 5/6/2009", "25/12/2009", "26/12/2009"))
        ActiveWorkbook.Names.Add Name:="Danemark", RefersTo:=[H3:H12]
 
        [I3:I13] = Application.Transpose(Array("1/1/2009", "6/1/2009", "13/4/2009", "25/4/2009", "1/5/2009", "2/6/2009", _
        "15/8/2009", "1/11/2009", "8/12/2009", "25/12/2009", "26/12/2009"))
        ActiveWorkbook.Names.Add Name:="Italie", RefersTo:=[I3:I13]
 
 
        Sheets("globale").Activate
        For i = Cells(65000, 10).End(xlUp).Row To 1 Step -1 'boucle de la dernière ligne colonne J à la première
    If Cells(i, 10) Like "GLS" Then Rows(i).Delete 'supprime la ligne si elle contient "GLS"
    Next
 
        Range("p3").Select
        ActiveCell.FormulaR1C1 = _
        "=IF(AND(RC[-11]=""A"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],Autriche),IF(AND(RC[-11]=""CH"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],Suisse),IF(AND(RC[-11]=""CZ"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],Tscheco),IF(AND(RC[-11]=""D"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],Allemagne),IF(AND(RC[-11]=""DK"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],Danemark),IF(AND(RC[-11]=""F"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],France),IF(AND(RC[-11]=""I"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],Italie),IF(AND(RC[-11]=""PL"",RC[-2]<>""""),NETWORKDAYS(RC[-3]+1,RC[-2],Pologne),""""))))))))"
        Range("p3").AutoFill Destination:=Range("p3:p10000"), Type:=xlFillDefault
 
        Range("Q3").Select
        ActiveCell.FormulaR1C1 = _
        "=IF(AND(RC[-13]=""znl"",LEFT(RC[-7],3)=""dhl"",RC[-4]+2<TODAY(),RC[-3]="""",COUNTIF(d24hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],3)=""dhl"",RC[-4]+3<TODAY(),RC[-3]="""",COUNTIF(d48hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],3)=""joy"",RC[-4]+2<TODAY(),RC[-3]="""",COUNTIF(j24hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],3)=""joy"",RC[-4]+3<TODAY(),RC[-3]="""",COUNTIF(j48hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],3)=""joy"",RC[-4]+4<TODAY(),RC[-3]="""",COUNTIF(j72hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],2)=""m-"",RC[-4]+2<TODAY(),RC[-3]="""",COUNTIF(m24hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],2)=""m-"",RC[-4]+3<TODAY(),RC[-3]="""",COUNTIF(m48hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],2)=""m-"",RC[-4]+4<TODAY(),RC[-3]="""",COUNTIF(m72hr,RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],2)=""m-"",RC[-4]+5<TODAY(),RC[-3]=""""," & _
            "COUNTIF(m96hr, RC[-11])),""pas livrée ?"",IF(AND(RC[-13]=""znl"",LEFT(RC[-7],3)=""tnt"",RC[-4]+2<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""znl"",RC[-12]=""A"",RC[-4]+3<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""znl"",RC[-12]=""D"",RC[-4]+2<TODAY(),RC[-3]=""""),""pas livrée ?"", IF(AND(RC[-13]=""znl"",RC[-12]=""Ch"",RC[-4]+3<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""znl"",RC[-12]=""D"",RC[-4]+2<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""znl"",RC[-12]=""cz"",RC[-4]+4<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""znl"",RC[-12]=""Dk"",RC[-4]+3<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""znl"",RC[-12]=""I"",RC[-4]+3<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""znl"",RC[-12]=""PL"",RC[-4]+4<TODAY(),RC[-3]=""""),""pas livrée ?"",IF(AND(RC[-13]=""zdl"",RC[-4]+5<TODAY(),RC[-3]=""""),""pas livrée ?"","""")))))))))))))))))))"
        Range("q3").AutoFill Destination:=Range("q3:q100000"), Type:=xlFillDefault
 
       Cells.Select
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    Dim NbLig As Long, T As Long, NbL As Long
    Dim Pays As String
 
    NbLig = Cells(Columns(2).Cells.Count, 2).End(xlUp).Row 'colonne 4 car données en D
 
    For T = 3 To NbLig 'de 6 car 1ère données en D6, boucle sur toutes les lignes de la feuille Globale
    Select Case Cells(T, 5).Value 'Récupère la valeur de la colonne G pour définir le pays
    'Case va choisir en fonction de la lettre récupérée via le Select Case
        Case Is = "A"
            Pays = "Autriche"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
 
          Case Is = "CH"
            Pays = "Suisse"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
 
           Case Is = "CZ"
            Pays = "CZ"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
 
            Case Is = "DK"
            Pays = "DK"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
 
 
        Case Is = "I"
            Pays = "Italie"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
 
        Case Is = "D"
            Pays = "Allemagne"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
 
        Case Is = "PL"
            Pays = "Pologne"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
        'Ajouter ici les autres Case selon ton fichier final
    End Select
 
Next T
 For T = 3 To NbLig 'de 6 car 1ère données en D6, boucle sur toutes les lignes de la feuille Globale
    Select Case (Left(Range("J" & T).Value, 3))
 
    ' Left("globale", Cells(10, T), 3) Récupère la valeur de la colonne G pour définir le pays
    'Case va choisir en fonction de la lettre récupérée via le Select Case
        Case Is = "TNT"
            Pays = "TNT"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
        Case Is = "TOF"
            Pays = "Tof"
            NbL = Sheets(Pays).Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
            Sheets("Globale").Range(Cells(T, 2), Cells(T, 17)).Copy Destination:=Sheets(Pays).Cells(NbL + 1, 1)
 End Select
 
Next T
 
 
    Dim c As Range, plage As Range
    Dim LastLig As Long, o As Long
    Dim sht As Worksheet, shtb As Worksheet, shtd As Worksheet
    Dim typtra As String, typdel As String, namsht As String
    Dim ind As Byte
 
    Set sht = Worksheets("globale")
    Set shtb = Sheets("carte des délais")
    LastLig = sht.Range("D65536").End(xlUp).Row
    For o = 3 To LastLig
        typtra = Left(sht.Range("J" & o), 1)
        Select Case UCase(typtra)
           Case "D"
                Set plage = shtb.Range("A2:C100")
                ind = 0
            Case "J"
                Set plage = shtb.Range("D2:F100")
                ind = 3
            Case "M"
               Set plage = shtb.Range("G2:i100")
                ind = 6
            Case Else: Exit Sub
        End Select
        Set c = plage.Find(sht.Range("F" & o).Value, LookIn:=xlValues, LookAt:=xlWhole)
       If Not c Is Nothing Then
            typdel = CStr((c.Column - ind) * 24)
            namsht = "" & LCase(typtra & typdel) & ""
            Set shtd = Sheets(namsht)
            shtd.Rows(shtd.Range("D65536").End(xlUp).Row + 1).Value = sht.Rows(o).Value
        End If
    Next o
 
Set sht = Nothing
Set shtb = Nothing
Set shtd = Nothing
End Sub

**Antoniom** · 07/10/2009, 12h38

Hello,

Quelqu'un veut de l'aspirine

la derniere partie de ma macro ne donne rien

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager