Faire un Vlookup dans une macro et le répéter

Version imprimable

Voir 40 message(s) de cette discussion en une page

22/10/2011, 14h58
Fred4345

J'utilise exactement le même code que tu m'as donné. J'ai juste changé les noms des feuilles. Dans le même classeur j'utilise ton code et je souhaite le réutiliser avec d'autres feuilles dont le nom n'est pas identique mais qui ont le même but.
22/10/2011, 15h23
mercatog

Citation:

j'utilise ton code et je souhaite le réutiliser avec d'autres feuilles dont le nom n'est pas identique mais qui ont le même but.

Dans le code, adapte les noms des feuilles aux nouveau noms.
22/10/2011, 18h41
Fred4345

je ne comprends pas ce que tu veux dire. Peux tu préciser stp.
J'ai déja essayé de tous renomer, mais sans succer! J'ai mis le nom des feuilles dans le code mais ça n'a rien donné.

Les cellules D6,F6,H6,J6,L6 de la feuille "demande" doivent contenir les valeurs trouvées dans la colonne H de la feuille "basecomposants" suivant la recherche effectuée en A:A de cette même feuille. Jusqu'ici cela fonctionne.
Mais ensuite les cellules D12,F12,H12,J12,L12,N12 doivent avoir les valeurs de la colonne N et ainsi de suite. Les cellules D18,F18,H18,J18,L18,N18 celle de la colonne T etc...
A chaque fois c'est la valeur trouvée en H qui est reportée.
Il faut lancer 2 fois la macro pour que les valeurs se repportent dans les cellules. Pourquoi? Est ce possible que l'opération s'effectue en une seule fois lors du lancement du code?

Code:

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
Sub Produit()
Dim CodProd As String
Dim LastLig As Long, i As Long
Dim c As Range
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("DEMANDE")
    LastLig = .Cells(.Rows.Count, "C").End(xlUp).Row
    For i = 4 To LastLig Step 6
        CodProd = .Range("C" & i)
        If CodProd <> "" Then
            Set c = Worksheets("BASE").Range("A:A").Find(CodProd, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                .Range("D" & i & ":O" & i).Value = c.Offset(0, 1).Resize(1, 12).Value
                .Range("B" & i + 3).Value = c.Offset(0, 13).Value
                Set c = Nothing
                Call RechComp(i)
            Else
                Call Efface(i)
            End If
        End If
    Next i
End With
Application.Calculation = xlCalculationAutomatic
End Sub
 
Private Sub RechComp(ByVal i As Long)
Dim Comp As String
Dim c As Range
Dim j As Byte
 
Application.ScreenUpdating = False
With Worksheets("DEMANDE")
    For j = 4 To 14 Step 2
        Comp = .Cells(i, j).Value
        If Comp <> "" Then
            Set c = Worksheets("BASECOMPOSANTS").Range("A:A").Find(Comp, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                .Cells(i + 2, j).Value = c.Offset(0, i + 3)
                Set c = Nothing
            Else
                .Cells(i + 2, j).ClearContents
            End If
        End If
    Next j
End With
End Sub
 
Private Sub Efface(ByVal i As Long)
Dim j As Byte
 
Application.ScreenUpdating = False
With Worksheets("DEMANDE")
    .Range("D" & i & ":O" & i).ClearContents
    For j = 4 To 14 Step 2
        .Cells(i + 2, j).ClearContents
    Next j
End With
End Sub

30/10/2011, 18h14
mercatog
Regarde la ligne 40

Code:

.Cells(i + 2, j).Value = c.Offset(0, i + 3)

c étant la cellule trouvée en colonne A de la feuille BASECOMPOSANTS et avec:
- j= 4, 6, 8....14 (cf. Sub RechComp)
- i= 4, 10, 16, 22.... (cf. Sub Produit)
Pour j =4 (colonne D)
- Pour i=4, on aura en D6: c.offset(0,7), c'est à dire colonne H
- Pour i=10, on aura en D12: c.offset(0, 13), c'est à dire colonne N
- Pour i=16, on aura en D18: c.offset(0,19), c'est à dire colonne T
Pour j =6 (colonne F)
- Pour i=4, on aura en F6: c.offset(0,7), c'est à dire colonne H
- Pour i=10, on aura en F12: c.offset(0, 13), c'est à dire colonne N
- Pour i=16, on aura en F18: c.offset(0,19), c'est à dire colonne T

Voici la modification apportée avec un collègue pour résoudre mon problème.
Ma question est maintenant bien résolu!:)

Code:

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
ublic k As Integer
Sub Demande_Produit()
Dim CodProd As String
Dim LastLig As Long, i As Long
Dim c As Range
k = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("DEMANDE")
    LastLig = .Cells(.Rows.Count, "C").End(xlUp).Row
    For i = 4 To LastLig Step 6
        CodProd1 = Range("C" & i).Value  
        CodProd = UCase(CodProd1)        
        Range("C" & i).Value = CodProd
        CodProd = .Range("C" & i)
        If CodProd <> "" Then
            Set c = Worksheets("BASE").Range("A:A").Find(CodProd, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                .Range("D" & i & ":O" & i).Value = c.Offset(0, 1).Resize(1, 12).Value
                .Range("B" & i + 3).Value = c.Offset(0, 13).Value
                Application.Calculation = xlCalculationAutomatic
                Application.Calculation = xlCalculationManuel
                Set c = Nothing
                Call RechComp(i)
            Else
                Call Efface(i)
            End If
        End If
        k = k + 6
    Next i
End With
Application.Calculation = xlCalculationAutomatic
End Sub
 
Private Sub RechComp(ByVal i As Long)
Dim Comp As String
Dim c As Range
Dim j As Byte
 
Application.ScreenUpdating = False
With Worksheets("DEMANDE")
    For j = 4 To 14 Step 2
        Comp = .Cells(i, j).Value
        If Comp <> "" Then
            Set c = Worksheets("BASECOMPOSANTS").Range("A:A").Find(Comp, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                .Cells(i + 2, j).Value = c.Offset(0, k)
                Set c = Nothing
            Else
                .Cells(i + 2, j).ClearContents
            End If
        End If
    Next j
End With
End Sub
 
Private Sub Efface(ByVal i As Long)
Dim j As Byte
 
Application.ScreenUpdating = False
With Worksheets("DEMANDE")
    .Range("D" & i & ":O" & i).ClearContents
    For j = 4 To 14 Step 2
        .Cells(i + 2, j).ClearContents
    Next j
End With
End Sub

Voir 40 message(s) de cette discussion en une page