Problème For eah cell next
n
Bonjour,
J'ai un code avec 3 plages différentes :
Range("B7:B21") j'ai name-1 à name-15 et dans la colonne C je n'ai que des A
Range("B23:B25") j'ai name-1, name-2 et name-300 et dans la colonne C je n'ai que des B
Range("B27:B36") j'ai name-1 et name-2 et de B29 à B36 name-700 à name-707 et dans la colonne C je n'ai que des C
Mon code marche à peu près mais je rencontre un problème.
Je m'explique :
Je rentre un "name-n" dans mon inputbox, par ex name-703.
Je compte d'abord le nombre de fois où il y a "name-703" dans ma plage (Présent qu'une seule fois)
Ensuite je trouve la lettre de la colonne C correspondant au name-703 (ici "C").
Je vérifie ensuite pour chaque cellule dans la plage de mes lettres que si la cellule est égale à la lettre trouvée, j'alimente ma plage RngEff avec chacune de ces cellules à l'aide de la fonction Union.
Pour cet exemple ma plage RngEff est donc Range("B27:B36")
Pour finir mes cellules de name-1 à name-703 se colorient en orange et de name-704 à name-707 en bleu et les autres Range restent du coup en XlNone.
Ce cas ci-dessus marche.
Par contre, si j'entre name-1 dans mon inputbox, vu qu'il est présent 3 fois je lance une autre macro.
C'est à peu près la même logique que précédemment sauf qu'ici je récupère chaque lettre de mes 3 ranges que je sauvegarde dans ma variable Effect que je split ensuite pour parcourir chacune d'entre elles.
Pour la première plage (B7 à B21 ça marche j'ai bien name-1 en orange et le reste en bleu) mais pour les 2 autres ça ne marche pas. Mon problème vient de mon for each cell qui me renvoi Nothing lorsque mon code se situe sur les lettres B et C ...
Voici mon code :
Je vous mets aussi le fichier pour mieux comprendre
Sub test1()
Dim x As String, NbTiret As Variant, n, NbRngTrouve As Integer
Dim DernCell As Boolean
Dim DerLig As Long, LastRow As Long, LastRowEff As Long, PremLig As Long, i As Long, j As Long, k As Long
Dim RngTrouve As Range, RngEff As Range, TxtTabTrouve As Range, Cell As Range, cel As Range
Dim EffectTrouve As String, TxtRngTrouve As String, Effect As String, Tableau() As String, TxtTab As String
Application.ScreenUpdating = False
LastRow = [B10000].End(xlUp).Row
LastRowEff = [C10000].End(xlUp).Row
Set RngEff = Range("c7:c" & LastRowEff)
On Error Resume Next
n = Range("b7:b" & LastRow).SpecialCells(xlCellTypeBlanks).Count
On Error GoTo 0
DerLig = [B7].CurrentRegion.Rows.Count
PremLig = Range("B1").End(xlDown).Row
DerLig = PremLig + DerLig
PremLig = Cells(DerLig, 2).End(xlDown).Row
For i = Range("b7").Row To LastRow
Cells(i, 2).Interior.ColorIndex = xlNone
Next i
x = InputBox("enter one/two number")
x = Replace(x, "name", "")
NbTiret = Split(x, "-")
Set RngTrouve = Range("B7:B" & LastRow).Find("name" & x, lookat:=xlWhole)
TxtRngTrouve = RngTrouve
NbRngTrouve = Application.WorksheetFunction.CountIf(Range("b7:b" & LastRow), RngTrouve)
If NbRngTrouve > 1 Then
For Each RngTrouve In Range("b7:b" & LastRow)
If RngTrouve = TxtRngTrouve Then
EffectTrouve = RngTrouve.Offset(0, 1)
Effect = Effect & "," & EffectTrouve
End If
Next
Do While Left(Effect, 1) = ","
Effect = Right(Effect, Len(Effect) - 1)
Loop
Tableau = Split(Effect, ",")
For k = 0 To UBound(Tableau)
TxtTab = Tableau(k)
Set TxtTabTrouve = Range("C7:C" & LastRowEff).Find(TxtTab, lookat:=xlWhole)
' If Not TxtTabTrouve Is Nothing Then
' maxi = Application.Max(TxtTabTrouve.Offset(, 1).Resize(Application.CountIf([A:A], Effect), 3))
' End If
For Each Cell In RngEff
If Cell = TxtTabTrouve Then
cpt = cpt + 1
If cpt = 1 Then
Set RngEff = Cell
Else
Set RngEff = Union(RngEff, Cell)
End If
End If
Next Cell
MsgBox RngEff.Address
Pos = RngEff.Row + RngEff.Rows.Count - 1
DerLig = RngEff.Row + RngEff.Rows.Count - 1
PremLig = RngEff.Row
For i = UBound(NbTiret) To 1 Step -1
If i = UBound(NbTiret) Then
For j = Pos To 1 Step -1
If Cells(Pos, "B") = "name-" & NbTiret(i) Then
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Pos = Pos - 1
Next j
Else
If NbTiret(i) = "/" Then
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Loop
ElseIf NbTiret(i) = "X" Then
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Loop
ElseIf IsNumeric(NbTiret(i)) Then
For j = Pos To 1 Step -1
If Cells(j, "B") = "name-" & NbTiret(i) Then
Cells(j, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = j - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Next j
Else
MsgBox "Erreur de saisie"
'Range("B7:B" & DerLig).Interior.ColorIndex = xlNone
End
End If
End If
Next i
'complétion des couleurs
For i = DerLig To PremLig + 1 Step -1
If Cells(i, "B").Interior.ColorIndex = xlNone Then
Cells(i, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
ElseIf Cells(i - 1, "B").Interior.ColorIndex = xlNone Then
Cells(i - 1, "B").Interior.Color = Cells(i, "B").Interior.Color
End If
Next i
Next k
ElseIf NbRngTrouve = 1 Then
EffectTrouve = RngTrouve.Offset(0, 1)
Effect = EffectTrouve
For Each Cell In RngEff
If Cell = Effect Then
cpt = cpt + 1
If cpt = 1 Then
Set RngEff = Cell
Else
Set RngEff = Union(RngEff, Cell)
End If
End If
Next Cell
MsgBox RngEff.Address
Pos = RngEff.Row + RngEff.Rows.Count - 1
DerLig = RngEff.Row + RngEff.Rows.Count - 1
PremLig = RngEff.Row
For i = UBound(NbTiret) To 1 Step -1
If i = UBound(NbTiret) Then
For j = Pos To 1 Step -1
If Cells(Pos, "B") = "name-" & NbTiret(i) Then
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Pos = Pos - 1
Next j
Else
If NbTiret(i) = "/" Then
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Loop
ElseIf NbTiret(i) = "X" Then
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Loop
ElseIf IsNumeric(NbTiret(i)) Then
For j = Pos To 1 Step -1
If Cells(j, "B") = "name-" & NbTiret(i) Then
Cells(j, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = j - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Next j
Else
MsgBox "Erreur de saisie"
'Range("B7:B" & DerLig).Interior.ColorIndex = xlNone
End
End If
End If
Next i
'complétion des couleurs
For i = DerLig To PremLig + 1 Step -1
If Cells(i, "B").Interior.ColorIndex = xlNone Then
Cells(i, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
ElseIf Cells(i - 1, "B").Interior.ColorIndex = xlNone Then
Cells(i - 1, "B").Interior.Color = Cells(i, "B").Interior.Color
End If
Next i
End If
End Subm
Slt nivk,
à tester.
Sub test1()
Dim x As String, NbTiret As Variant, n, NbRngTrouve As Integer
Dim DernCell As Boolean
Dim DerLig As Long, LastRow As Long, LastRowEff As Long, PremLig As Long, i As Long, j As Long, k As Long
Dim RngTrouve As Range, RngEff As Range, TxtTabTrouve As Range, Cell As Range, cel As Range
Dim EffectTrouve As String, TxtRngTrouve As String, Effect As String, Tableau() As String, TxtTab As String
Application.ScreenUpdating = False
LastRow = [B10000].End(xlUp).Row
LastRowEff = [C10000].End(xlUp).Row
Set RngEff = Range("c7:c" & LastRowEff)
On Error Resume Next
n = Range("b7:b" & LastRow).SpecialCells(xlCellTypeBlanks).Count
On Error GoTo 0
DerLig = [B7].CurrentRegion.Rows.Count
PremLig = Range("B1").End(xlDown).Row
DerLig = PremLig + DerLig
PremLig = Cells(DerLig, 2).End(xlDown).Row
For i = Range("b7").Row To LastRow
Cells(i, 2).Interior.ColorIndex = xlNone
Next i
x = InputBox("enter one/two number")
x = Replace(x, "name", "")
NbTiret = Split(x, "-")
Set RngTrouve = Range("B7:B" & LastRow).Find("name" & x, lookat:=xlWhole)
TxtRngTrouve = RngTrouve
NbRngTrouve = Application.WorksheetFunction.CountIf(Range("b7:b" & LastRow), RngTrouve)
If NbRngTrouve > 1 Then
For Each RngTrouve In Range("b7:b" & LastRow)
If RngTrouve = TxtRngTrouve Then
EffectTrouve = RngTrouve.Offset(0, 1)
Effect = Effect & "," & EffectTrouve
End If
Next
Do While Left(Effect, 1) = ","
Effect = Right(Effect, Len(Effect) - 1)
Loop
Tableau = Split(Effect, ",")
For k = 0 To UBound(Tableau)
TxtTab = Tableau(k)
Set TxtTabTrouve = Range("C7:C" & LastRowEff).Find(TxtTab, lookat:=xlWhole)
' If Not TxtTabTrouve Is Nothing Then
' maxi = Application.Max(TxtTabTrouve.Offset(, 1).Resize(Application.CountIf([A:A], Effect), 3))
' End If
For Each Cell In RngEff
If Cell = TxtTabTrouve Then
cpt = cpt + 1
If cpt = 1 Then
Set RngEff = Cell
Else
Set RngEff = Union(RngEff, Cell)
End If
End If
Next Cell
MsgBox RngEff.Address
Pos = RngEff.Row + RngEff.Rows.Count - 1
DerLig = RngEff.Row + RngEff.Rows.Count - 1
PremLig = RngEff.Row
For i = UBound(NbTiret) To 1 Step -1
If i = UBound(NbTiret) Then
For j = Pos To 1 Step -1
If Cells(Pos, "B") = "name-" & NbTiret(i) Then
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Pos = Pos - 1
Next j
Else
If NbTiret(i) = "/" Then
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Loop
ElseIf NbTiret(i) = "X" Then
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Loop
ElseIf IsNumeric(NbTiret(i)) Then
For j = Pos To 1 Step -1
If Cells(j, "B") = "name-" & NbTiret(i) Then
Cells(j, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = j - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Next j
Else
MsgBox "Erreur de saisie"
'Range("B7:B" & DerLig).Interior.ColorIndex = xlNone
End
End If
End If
Next i
'complétion des couleurs
For i = DerLig To PremLig + 1 Step -1
If Cells(i, "B").Interior.ColorIndex = xlNone Then
Cells(i, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
ElseIf Cells(i - 1, "B").Interior.ColorIndex = xlNone Then
Cells(i - 1, "B").Interior.Color = Cells(i, "B").Interior.Color
End If
Next i
cpt = 0
Set RngEff = Range("c7:c" & LastRowEff)
Next k
ElseIf NbRngTrouve = 1 Then
EffectTrouve = RngTrouve.Offset(0, 1)
Effect = EffectTrouve
For Each Cell In RngEff
If Cell = Effect Then
cpt = cpt + 1
If cpt = 1 Then
Set RngEff = Cell
Else
Set RngEff = Union(RngEff, Cell)
End If
End If
Next Cell
MsgBox RngEff.Address
Pos = RngEff.Row + RngEff.Rows.Count - 1
DerLig = RngEff.Row + RngEff.Rows.Count - 1
PremLig = RngEff.Row
For i = UBound(NbTiret) To 1 Step -1
If i = UBound(NbTiret) Then
For j = Pos To 1 Step -1
If Cells(Pos, "B") = "name-" & NbTiret(i) Then
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Pos = Pos - 1
Next j
Else
If NbTiret(i) = "/" Then
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
Pos = Pos - 1
Loop
ElseIf NbTiret(i) = "X" Then
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(146, 208, 80) ' Vert
Pos = Pos - 1
Loop
ElseIf IsNumeric(NbTiret(i)) Then
For j = Pos To 1 Step -1
If Cells(j, "B") = "name-" & NbTiret(i) Then
Cells(j, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = j - 1
Do While Cells(Pos, "B") = Cells(Pos + 1, "B")
Cells(Pos, "B").Interior.Color = RGB(255, 192, 50) 'Orange
Pos = Pos - 1
Loop
Exit For
End If
Next j
Else
MsgBox "Erreur de saisie"
'Range("B7:B" & DerLig).Interior.ColorIndex = xlNone
End
End If
End If
Next i
'complétion des couleurs
For i = DerLig To PremLig + 1 Step -1
If Cells(i, "B").Interior.ColorIndex = xlNone Then
Cells(i, "B").Interior.Color = RGB(83, 142, 213) 'Bleu
ElseIf Cells(i - 1, "B").Interior.ColorIndex = xlNone Then
Cells(i - 1, "B").Interior.Color = Cells(i, "B").Interior.Color
End If
Next i
End If
End Subn
Salut m3ellem1,
Super merci ça marche il fallait y penser