XL 2013 Multi VLOOKUP

brunos31 · 17 Décembre 2017

Bonjour à tous,

Je me posé une question, à savoir si il est possible de générer un tableau en recherchev selon plusieurs critères en VBA.

Je m'explique. J'ai un tableau qui regarde un certains nombre d'item dans une feuille "Table", si l'item trouvé à la valeur qui match avec le mot qui est stocké sur une autre feuille "Dashboard", il remonte dans le tableau. Puis par rapport à ce numéros d'item, il doit chercher une valeur correspondante en croisant les données tel que la date et un type de travaux donnée.

Je pense que le fichier join ne sera pas de trop pour vous montrer plus précisément ce que je cherche ^^

Merci d'avance pour votre aide.

Bebere · 18 Décembre 2017

bonjour
Bruno bienvenue
une solution

Code:

Sub suite()
    Dim L As Long, C As Long
    Dim Cel As Range, Cel1 As Range

    For Each Cel In Sheets("PROD").Range("A1:Q1")   'date 18-12-17
        If Cel = Sheets("Matrice").Range("BJ1") Then C = Cel.Column: Exit For
    Next
    If C > 0 Then    '88
        For Each Cel1 In Sheets("Matrice").Range("BK1:BT1")
            For Each Cel In Sheets("PROD").Range("A2:A11")
                If Left(Cel, Len(Cel1)) = Cel1 Then L = Cel.Row: Exit For
            Next
            Sheets("Matrice").Cells(2, Cel1.Column) = Sheets("PROD").Cells(L, C)
        Next
    End If

    For Each Cel In Sheets("PROD").Range("A12:Q12")   'date 18-12-17
        If Cel = Sheets("Matrice").Range("BJ1") Then C = Cel.Column: Exit For
    Next
    If C > 0 Then    '132
        For Each Cel1 In Sheets("Matrice").Range("BK1:BT1")
            For Each Cel In Sheets("PROD").Range("A13:A22")
                If Left(Cel, Len(Cel1)) = Cel1 Then L = Cel.Row: Exit For
            Next
            Sheets("Matrice").Cells(3, Cel1.Column) = Sheets("PROD").Cells(L, C)
        Next
    End If

End Sub

brunos31 · 18 Décembre 2017

Bonjour Bebere,

Merci beaucoup pour ton aide. Je modifie le script pour avoir une boucle toutes les 11 lignes, car le nombre d'item dans la feuille "PROD" est inconnue, seul le nombre de ligne entre nouveau item est constant, soit toutes les 11 lignes.

VB:

Option Explicit
Sub test()
'--------------------------------------------------------------------------------------------------------------------------
'Variable
'--------------------------------------------------------------------------------------------------------------------------
  Dim suite As Range 'variable range
  Dim cellule As Range 'variable range
  Dim value1 As Range 'variable text
  Dim L As Long, C As Long
  Dim Cel As Range, Cel1 As Range
  Dim i As Long
  Dim DerniereLigne As Long
'--------------------------------------------------------------------------------------------------------------------------
'MSN link to SCOPE
'--------------------------------------------------------------------------------------------------------------------------
  'Source value
  Set value1 = Sheets("Dashboard").Range("A2")
  'Search the value in extract tab
  For Each cellule In Sheets("Table").Range("Q2:Q" & Sheets("Table").Range("A65535").End(xlUp).Row)
  Set suite = Sheets("Matrice").[BJ65536].End(xlUp).Offset(1, 0)
  If cellule = value1 Then
  'Write the resultat
  Sheets("Matrice").Range("BJ" & Sheets("Matrice").Range("BJ65535").End(xlUp).Row + 1) = Sheets("Table").Cells(cellule.Row, 1)
  End If
  Next
'--------------------------------------------------------------------------------------------------------------------------
'Consolidation Hours
'-------------------------------------------------------------------------------------------------------------------------
DerniereLigne = Range("A65536").End(xlUp).Row
For i = 1 To DerniereLigne Step 11
  For Each Cel In Sheets("PROD").Range("A" & i & ":Q" & i + 11)
  If Cel = Sheets("Matrice").Range("BJ1") Then C = Cel.Column: Exit For
  Next

  If C > 0 Then
  For Each Cel1 In Sheets("Matrice").Range("BK1:BT1")
  For Each Cel In Sheets("PROD").Range("A" & i & ":A" & i + 11)
  If Left(Cel, Len(Cel1)) = Cel1 Then L = Cel.Row: Exit For
  Next
  Sheets("Matrice").Cells(2, Cel1.Column) = Sheets("PROD").Cells(L, C)
  Next
  End If
Next i
'--------------------------------------------------------------------------------------------------------------------------
'Clear memory system
'--------------------------------------------------------------------------------------------------------------------------
  Set Cel = Nothing
  Set Cel1 = Nothing
  Set suite = Nothing
  Set cellule = Nothing
  Set value1 = Nothing
End Sub

Bebere · 18 Décembre 2017

bonjour
Bruno mis les heures au format hh:mm,pour moi suite n'est pas utile

Code:

Sub test()
'--------------------------------------------------------------------------------------------------------------------------
'Variable
'--------------------------------------------------------------------------------------------------------------------------
'    Dim suite As Range 'variable range
    Dim cellule As Range 'variable range
    Dim value1 As Range 'variable text
    Dim L As Long, Li As Long, C As Long
    Dim Cel As Range, Cel1 As Range
    Dim derligne As Integer
    Dim i As Byte
'--------------------------------------------------------------------------------------------------------------------------
'MSN link to SCOPE
'--------------------------------------------------------------------------------------------------------------------------
  'Source value
  Set value1 = Sheets("Dashboard").Range("A2")
  'Search the value in extract tab
  For Each cellule In Sheets("Table").Range("Q2:Q" & Sheets("Table").Range("A65535").End(xlUp).Row)
'  Set suite = Sheets("Matrice").[BJ65536].End(xlUp).Offset(1, 0)
  If cellule = value1 Then
  'Write the resultat
  Sheets("Matrice").Range("BJ" & Sheets("Matrice").Range("BJ65535").End(xlUp).Row + 1) = Sheets("Table").Cells(cellule.Row, 1)
  End If
  Next
'--------------------------------------------------------------------------------------------------------------------------
'Consolidation Hours
'-------------------------------------------------------------------------------------------------------------------------
derligne = Sheets("PROD").Cells(65000, 1).End(xlUp).Row
Li = 2
For i = 1 To derligne Step 11
If IsDate(Sheets("PROD").Cells(i, 2)) Then
    For Each Cel In Sheets("PROD").Range("A" & i & ":Q" & i)
        If Cel = Sheets("Matrice").Range("BJ1") Then C = Cel.Column: Exit For
    Next
    If C > 0 Then
        For Each Cel1 In Sheets("Matrice").Range("BK1:BT1")
            For Each Cel In Sheets("PROD").Range("A" & i + 1 & ":A" & i + 10)
                If Left(Cel, Len(Cel1)) = Cel1 Then L = Cel.Row: Exit For
            Next
            Sheets("Matrice").Cells(Li, Cel1.Column) = CDate(Sheets("PROD").Cells(L, C) / 24)
            Sheets("Matrice").Cells(Li, Cel1.Column).NumberFormat = "[hh]:mm"
        Next
    End If
End If
Li = Li + 1
Next i
'--------------------------------------------------------------------------------------------------------------------------
'Clear memory system
'--------------------------------------------------------------------------------------------------------------------------
  Set Cel = Nothing
  Set Cel1 = Nothing
  Set suite = Nothing
  Set cellule = Nothing
  Set value1 = Nothing
End Sub

brunos31 · 18 Décembre 2017

Merci Bebere,

J'ai remodifier, j'ai pas besoin d'avoir un affichage par heure car j'ai des valeurs pour le nombre de personne voulu et un nombre d'heure. Mais c'est gentil, c'est bon à savoir.

Par contre il me rajoute une ligne en plus à la fin dans le vide.... Je vais essayer de voir d'où vient ce bug.

VB:

derligne = Sheets("PROD").Cells(65000, 1).End(xlUp).Row
Li = 2
For i = 1 To derligne Step 11
If IsDate(Sheets("PROD").Cells(i, 2)) Then
    For Each Cel In Sheets("PROD").Range("A" & i & ":Q" & i)
        If Cel = Sheets("Matrice").Range("BJ1") Then C = Cel.Column: Exit For
    Next
    If C > 0 Then
        For Each Cel1 In Sheets("Matrice").Range("BK1:BT1")
            For Each Cel In Sheets("PROD").Range("A" & i + 1 & ":A" & i + 10)
                If Left(Cel, Len(Cel1)) = Cel1 Then L = Cel.Row: Exit For
            Next
            Sheets("Matrice").Cells(Li, Cel1.Column) = CDate(Sheets("PROD").Cells(L, C))
            Sheets("Matrice").Cells(Li, Cel1.Column).NumberFormat = "0.0"
        Next
    End If
End If
Li = Li + 1
Next i

Merci beaucoup de ton aide

brunos31 · 18 Décembre 2017

Effectivement le suite était pas utile, merci de l'infos

brunos31 · 18 Décembre 2017

Je pense savoir d'où ça vient, il manque une première loop. Qui consiste à prendre uniquement le numéros d'item qui est flagé "FL" (valeur cherché en sheets("Dashboard").Range("A2")) dans la feuille "TABLE"

Bebere · 18 Décembre 2017

bonsoir
Bruno regarde les 2 lignes commentées ajout

Code:

Sub test()
'--------------------------------------------------------------------------------------------------------------------------
'Variable
'--------------------------------------------------------------------------------------------------------------------------
'    Dim suite As Range 'variable range
    Dim cellule As Range 'variable range
    Dim value1 As Range 'variable text
    Dim L As Long, Li As Long, C As Long
    Dim Cel As Range, Cel1 As Range
    Dim derligne As Integer
    Dim i As Byte, x
    Sheets("Matrice").Range("BJ2:BT" & Sheets("Matrice").Range("BJ65535").End(xlUp).Row).ClearContents 'ajout
'--------------------------------------------------------------------------------------------------------------------------
'MSN link to SCOPE
'--------------------------------------------------------------------------------------------------------------------------
  'Source value
  Set value1 = Sheets("Dashboard").Range("A2")
  'Search the value in extract tab
  For Each cellule In Sheets("Table").Range("Q2:Q" & Sheets("Table").Range("A65535").End(xlUp).Row)
'  Set suite = Sheets("Matrice").[BJ65536].End(xlUp).Offset(1, 0)
  If cellule = value1 Then
  'Write the resultat
  Sheets("Matrice").Range("BJ" & Sheets("Matrice").Range("BJ65535").End(xlUp).Row + 1) = Sheets("Table").Cells(cellule.Row, 1)
  End If
  Next
'--------------------------------------------------------------------------------------------------------------------------
'Consolidation Hours
'-------------------------------------------------------------------------------------------------------------------------
derligne = Sheets("PROD").Cells(65000, 1).End(xlUp).Row
Li = 2
For i = 1 To derligne Step 11
If IsDate(Sheets("PROD").Cells(i, 2)) Then
    For Each Cel In Sheets("PROD").Range("A" & i & ":Q" & i)
        If Cel = Sheets("Matrice").Range("BJ1") Then C = Cel.Column: Exit For
    Next
    If C > 0 Then
        For Each Cel1 In Sheets("Matrice").Range("BK1:BT1")
            For Each Cel In Sheets("PROD").Range("A" & i + 1 & ":A" & i + 10)
                If Left(Cel, Len(Cel1)) = Cel1 Then L = Cel.Row: Exit For
            Next
            Sheets("Matrice").Cells(Li, Cel1.Column) = CDate(Sheets("PROD").Cells(L, C) / 24)
            Sheets("Matrice").Cells(Li, Cel1.Column).NumberFormat = "[hh]:mm"
        Next
    End If
End If
Li = Li + 1
If Sheets("Matrice").Range("BJ" & Li) = "" Then Exit For 'ajout
Next i
'--------------------------------------------------------------------------------------------------------------------------
'Clear memory system
'--------------------------------------------------------------------------------------------------------------------------
  Set Cel = Nothing
  Set Cel1 = Nothing
'  Set suite = Nothing
  Set cellule = Nothing
  Set value1 = Nothing
End Sub

Effectuez une recherche sur Excel Downloads...

XL 2013 Multi VLOOKUP

brunos31

XLDnaute Nouveau

Pièces jointes

Bebere

XLDnaute Barbatruc

brunos31

XLDnaute Nouveau

Pièces jointes

Bebere

XLDnaute Barbatruc

brunos31

XLDnaute Nouveau

Pièces jointes

brunos31

XLDnaute Nouveau

brunos31

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

Discussions similaires

Nous accordons de l'importance à votre vie privée