Problème plusieurs plages sur planning VBA
bonjour
je cherche encore et toujours une solution pour faire apparaitre les noms des gens qui ont réservé sur mon planning pour chaque véhicule, en sachant qu'une personne peut prendre plusieurs véhicules :
Les véhicules concernés sont dans les colonnes E,F,G de la feuille "Réservation"
Si une âme charitable se propose de m'aider
Merci pour votre aide
Le code c-dessous fonctionne très bien pour une colonne dans "réservation" mais pour plusieurs... je n'y arrive pas..
Option Explicit
Dim fr, fp, ln, i, hd, hr, cold, colr, cell
Private Sub Worksheet_Deactivate()
Set fr = Sheets("Réservation")
Set fp = Sheets("Planning")
'Initialisation du planning
fp.Range(fp.Cells(3, 2), fp.Cells(fp.Cells(Rows.Count, 1).End(xlUp).Row, fp.Cells(2, Columns.Count).End(xlToLeft).Column)).ClearContents
fp.Range(fp.Cells(3, 2), fp.Cells(fp.Cells(Rows.Count, 1).End(xlUp).Row, fp.Cells(2, Columns.Count).End(xlToLeft).Column)).Interior.Color = xlNone
'Boucles
For ln = 3 To fp.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To fr.Range("E,F,G" & Rows.Count).End(xlUp).Row
If fp.Range("A" & ln) = fr.Range("E,F,G" & i) Then
hd = fr.Range("J" & i)
hr = fr.Range("K" & i)
Set cell = fp.Rows("2:2").Find(hd, lookat:=xlWhole)
If Not cell Is Nothing Then
cold = cell.Column
Else
Exit For
End If
Set cell = fp.Rows("2:2").Find(hr, lookat:=xlWhole)
If Not cell Is Nothing Then
colr = cell.Column
Else
colr = Cells(2, Columns.Count).End(xlToLeft).Column
End If
fp.Cells(ln, cold) = fr.Range("A" & i)
fp.Range(fp.Cells(ln, cold), fp.Cells(ln, colr)).Interior.Color = RGB(218, 150, 148)
End If
Next i
Next ln
End Sub
Ca y est !
J'ai trouvé, je met le code pour ceux que ça intéresse !
Merci à ceux qui m'ont aidé
- Ne jamais désespérer mais persévérer ! -
Option Explicit
Dim fr, fp, ln, i, hd, hr, cold, colr, cell
Private Sub Worksheet_Deactivate()
Set fr = Sheets("Réservation")
Set fp = Sheets("Planning")
'Initialisation du planning
fp.Range(fp.Cells(3, 2), fp.Cells(fp.Cells(Rows.Count, 1).End(xlUp).Row, fp.Cells(2, Columns.Count).End(xlToLeft).Column)).ClearContents
fp.Range(fp.Cells(3, 2), fp.Cells(fp.Cells(Rows.Count, 1).End(xlUp).Row, fp.Cells(2, Columns.Count).End(xlToLeft).Column)).Interior.Color = xlNone
'Boucles
For ln = 3 To fp.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To fr.Range("E" & Rows.Count).End(xlUp).Row
If fp.Range("A" & ln) = fr.Range("E" & i) Then
hd = fr.Range("J" & i)
hr = fr.Range("K" & i)
Set cell = fp.Rows("2:2").Find(hd, lookat:=xlWhole)
If Not cell Is Nothing Then
cold = cell.Column
Else
Exit For
End If
Set cell = fp.Rows("2:2").Find(hr, lookat:=xlWhole)
If Not cell Is Nothing Then
colr = cell.Column
Else
colr = Cells(2, Columns.Count).End(xlToLeft).Column
End If
fp.Cells(ln, cold) = fr.Range("A" & i)
fp.Range(fp.Cells(ln, cold), fp.Cells(ln, colr)).Interior.Color = RGB(218, 150, 148)
End If
Next i
Next ln
For ln = 3 To fp.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To fr.Range("F" & Rows.Count).End(xlUp).Row
If fp.Range("A" & ln) = fr.Range("F" & i) Then
hd = fr.Range("J" & i)
hr = fr.Range("K" & i)
Set cell = fp.Rows("2:2").Find(hd, lookat:=xlWhole)
If Not cell Is Nothing Then
cold = cell.Column
Else
Exit For
End If
Set cell = fp.Rows("2:2").Find(hr, lookat:=xlWhole)
If Not cell Is Nothing Then
colr = cell.Column
Else
colr = Cells(2, Columns.Count).End(xlToLeft).Column
End If
fp.Cells(ln, cold) = fr.Range("A" & i)
fp.Range(fp.Cells(ln, cold), fp.Cells(ln, colr)).Interior.Color = RGB(218, 150, 148)
End If
Next i
Next ln
For ln = 3 To fp.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To fr.Range("G" & Rows.Count).End(xlUp).Row
If fp.Range("A" & ln) = fr.Range("G" & i) Then
hd = fr.Range("J" & i)
hr = fr.Range("K" & i)
Set cell = fp.Rows("2:2").Find(hd, lookat:=xlWhole)
If Not cell Is Nothing Then
cold = cell.Column
Else
Exit For
End If
Set cell = fp.Rows("2:2").Find(hr, lookat:=xlWhole)
If Not cell Is Nothing Then
colr = cell.Column
Else
colr = Cells(2, Columns.Count).End(xlToLeft).Column
End If
fp.Cells(ln, cold) = fr.Range("A" & i)
fp.Range(fp.Cells(ln, cold), fp.Cells(ln, colr)).Interior.Color = RGB(218, 150, 148)
End If
Next i
Next ln
End Sub