Range(Cells(2, j + 3)).Value
Sub TrouverCalibre() 'Affecter un calibre en fonction du poids pesé d'un produit choisi dans la liste 'Dans la feuil(1) : 'Liste produit = D3:D5 'Plage calibres = E3:H5 'Nom des Calibres = E2:H2 'Choix liste en A3 nommé "Choix" 'Poids pesé en B3 nommé "Pds" 'Calibre trouvé en C3 nommé "Clb" Dim i, j, Pds Application.ScreenUpdating = False ActiveSheet.Unprotect 'Dans la Liste de la ligne 3 à 6 (on pourrait récupérer ces valeurs Row automatiquement) For i = 3 To 6 'Dans Plage des valeurs de calibre (on pourrait récupérer ces valeurs Row & Column automatiquement) For j = 2 To 5 'Valeur par défaut Range("Clb").Value = "Hors Calibre" 'Si résultat VlookUp = Vide: aller au pas de macro suivant On Error Resume Next 'Code1 Pourquoi ça ne marche pas, sauf pour les 3 premiers calibres du premier choix ? '°°°°° ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 'If Range("Pds").Value < Application.WorksheetFunction.VLookup(Range("Choix"), Range("D" & i & ":H" & i), j, False) _ Then Range("Clb").Value = Range(Lettre & "2").Value _ : Exit Sub 'Code 2 En passant par "Pds" et "Cell", ça marche pour tous les choix et tous les calibres. '°°°°°° Pds Application.WorksheetFunction.VLookup(Range("Choix"), Range("D" & i & ":H" & i), j, False) If Range("Pds").Value < Pds _ Then Range("Clb").Value = Cells(2, j + 3).Value _ : Exit Sub Next j Next i ActiveSheet.Protect End Sub '*************************************************************************** Private Sub Worksheet_Change(ByVal Target As Range) 'Pour tout changement de valeur une des 2 cellules déverrouillées 'Changement du Choix dans la liste If Not Intersect(Target, Range("Choix")) Is Nothing Then TrouverCalibre 'Changement du Poids pesé If Not Intersect(Target, Range("Pds")) Is Nothing Then TrouverCalibre 'Changement du poids pesé End Sub
Sub Demo() Dim Msg On Error Resume Next 'une fois la valeur trouvée via le find, le offset nous décale de 2 colonnes soit sur la 3ieme colonne. Msg = Range("FruitsTable").Find("pomme", MatchCase:=False).Offset(0, 2).Value If Not Err 0 Then Msg "valeur non trouvée ! " On Error GoTo 0 'annule le précédent On Error Resume Next MsgBox Msg End Sub
Function Col(LC As Variant) As String LetCol = Array( _ "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _ "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", _ "BA", "BB", "BC", "BD", "BE", "BF", "BG", "BH", "BI", "BJ", "BK", "BL", "BM", "BN", "BO", "BP", "BQ", "BR", "BS", "BT", "BU", "BV", "BW", "BX", "BY", "BZ", _ "CA", "CB", "CC", "CD", "CE", "CF", "CG", "CH", "CI", "CJ", "CK", "CL", "CM", "CN", "CO", "CP", "CQ", "CR", "CS", "CT", "CU", "CV", "CW", "CX", "CY", "CZ", _ "DA", "DB", "DC", "DD", "DE", "DF", "DG", "DH", "DI", "DJ", "DK", "DL", "DM", "DN", "DO", "DP", "DQ", "DR", "DS", "DT", "DU", "DV", "DW", "DX", "DY", "DZ") Col = LetCol(LC) End Function '======= Sub Calibre() Dim i, j On Error Resume Next 'On retrouve son calibre en fonction du poids entré If Range("A3").Value >= Application.WorksheetFunction.VLookup(Range("A3"), Sheets(1).Range("D3:J6"), 1, False) Then For i = 3 To 6 For j = 2 To 6 xx = 0 yy = 0 xx = Application.WorksheetFunction.VLookup(Range("A3"), Sheets(1).Range("D" & i & ":J" & i), j, False) yy = Application.WorksheetFunction.VLookup(Range("A3"), Sheets(1).Range("D" & i & ":J" & i), j + 1, False) If (Range("B3").Value >xx Or xx "<") And Range("B3").Value < yy Then Range("C3").Value = Range(Col(j + 2) & "2").Value Exit For End If Next j If (Range("B3").Value >xx Or xx "X") And Range("B3").Value < yy Then Exit For Next i End If End Sub '======= Private Sub Worksheet_Change(ByVal Target As Range) 'Pour tout changement de valeur dans les cellules déverrouillées If Not Intersect(Target, Range("A3")) Is Nothing Then Calibre If Not Intersect(Target, Range("B3")) Is Nothing Then Calibre End Sub
Function Col(LC As Variant) As String 'Il y a peut-être plus simple pour récupérer la(les) lettre(s) d'une colonne à partir sa position... LetCol = Array( _ "A", "B", "C", "D", "E", "F", "G", "H") 'etc... Col = LetCol(LC) End Function '========== Sub Calibre() 'Affecter un calibre en fonction du poids pesé d'un produit choisi dans la liste 'Dans la feuil(1) : 'Liste produit = D3:D5 'Plage calibres = E3:H5 'Nom des Calibres = E2:H2 'Choix liste en A3 nommé "Choix" 'Poids pesé en B3 nommé "Pds" 'Calibre trouvé en C3 nommé "Clb" Dim i, j, p Application.ScreenUpdating = False ActiveSheet.Unprotect For i = 3 To 6 'Liste de la ligne 3 à 6 (on pourra faire remonter ces valeurs automatiquement) For j = 2 To 5 'Plage des valeurs de calibre (idem) selon des colonnes avec fonction LetCol(LC) On Error Resume Next 'OBLIGATOIRE ! Pourquoi ? Range("Clb").Value = "Hors Calibre" 'Valeur par défaut 'En passant par "p", ça marche... 'p Application.WorksheetFunction.VLookup(Range("Choix"), Sheets(1).Range("D" & i & ":H" & i), j, False) If Range("Pds").Value < p _ Then Range("Clb").Value = Range(Col(j + 2) & "2").Value _ : Exit Sub 'Pourquoi là ça ne marche pas ??? '================================ 'If Range("Pds").Value < Application.WorksheetFunction.VLookup(Range("Choix"), Sheets(1).Range("D" & i & ":H" & i), j, False) _ Then Range("Clb").Value = Range(Col(j + 2) & "2").Value _ : Exit Sub Error Clear 'RAZ de On Error... Est-ce bien utile ??? Next j Next i ActiveSheet.Protect End Sub '========== Private Sub Worksheet_Change(ByVal Target As Range) 'Pour tout changement de valeur dans les cellules déverrouillées If Not Intersect(Target, Range("Choix")) Is Nothing Then Calibre 'Changement de choix If Not Intersect(Target, Range("Pds")) Is Nothing Then Calibre 'Changement du poids pesé End Sub
Function Col(LC As Variant) As String Dim ColAdresse As String ColAdresse = Columns(LC).Address(False, False) Col = Left$(ColAdresse, InStr(1, ColAdresse, ":") - 1) End Function
Then Range("Clb").Value = Range(Cells(2, j + 2)).Value
Function Col(Byval LC As Long) As String 'LC dimensionné à long car la propriété columns attend un long Dim ColAdresse As String ColAdresse = Columns(LC).Address(False, False) Col = Left$(ColAdresse, InStr(1, ColAdresse, ":") - 1) End Function
Sub TrouverCalibre() 'Affecter un calibre en fonction du poids pesé d'un produit choisi dans la liste 'Dans la feuil(1) : 'Liste produit = D3:D5 'Plage calibres = E3:H5 'Nom des Calibres = E2:H2 'Choix liste en A3 nommé "Choix" 'Poids pesé en B3 nommé "Pds" 'Calibre trouvé en C3 nommé "Clb" Dim i, j, Pds Application.ScreenUpdating = False ActiveSheet.Unprotect 'Dans la Liste de la ligne 3 à 6 (on pourrait récupérer ces valeurs Row automatiquement) For i = 3 To 6 'Dans Plage des valeurs de calibre (on pourrait récupérer ces valeurs Row & Column automatiquement) For j = 2 To 5 'Récupérer la lettre de la colonne NumCol = Cells(1, j + 3).Column Lettre = IIf(NumCol > 26, Chr(64 + NumCol \ 26) & Chr(64 + NumCol Mod 26), Chr(64 + NumCol)) 'Valeur par défaut Range("Clb").Value = "Hors Calibre" 'Si résultat VlookUp = Vide: aller au pas de macro suivant On Error Resume Next 'Code1 Pourquoi ça ne marche pas, sauf pour les 3 premiers calibres du premier choix ? '°°°°° ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 'If Range("Pds").Value < Application.WorksheetFunction.VLookup(Range("Choix"), Range("D" & i & ":H" & i), j, False) _ Then Range("Clb").Value = Range(Lettre & "2").Value _ : Exit Sub 'Code 2 En passant par "Pds" et "Lettre", ça marche pour tous les choix et tous les calibres...! '°°°°°° Pds Application.WorksheetFunction.VLookup(Range("Choix"), Range("D" & i & ":H" & i), j, False) If Range("Pds").Value < Pds _ Then Range("Clb").Value = Range(Lettre & "2").Value _ : Exit Sub 'Code 3 Pourquoi ça ne marche plus en passant par "Cells" au ieu de "Lettre" ? '°°°°°° ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 'Pds = Application.WorksheetFunction.VLookup(Range("Choix"), Range("D" & i & ":H" & i), j, False) 'If Range("Pds").Value < Pds _ Then Range("Clb").Value = Range(Cells(2, j + 3)).Value _ : Exit Sub Next j Next i ActiveSheet.Protect End Sub