target as range

[prw79]

How can i add more sheets and ranges within the same and following VBA. For the record: This code results in having the same text and background color in a dropdown list as it is in the original list.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Not Intersect(Target, Range("B2:B32")) Is Nothing Then
With Target
.Interior.Color = Sheets("Maandoverzicht ploeg 2").Range("C11:c40").Find(Target).Interior.Color
.Font.Color = Sheets("Maandoverzicht ploeg 2").Range("C11:c40").Find(Target).Font.Color
.Font.Bold = Sheets("Maandoverzicht ploeg 2").Range("C11:c40").Find(Target).Font.Bold
End With
End If
End Sub

thanks in advance

 

[cmowla]

Hi.

Based on what you wrote, this is my best guess as to what you need.

Firstly, put this small function in a (any) standard VBA code module of your choice:
(Its purpose is to condense and make the code readable.)

Function These_Two_Intersect(range1 As Range, range2Address As String)
These_Two_Intersect = Not Intersect(range1, Range(range2Address)) Is Nothing
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.CountLarge > 1) Or (Target.Value = "") Then Exit Sub

Dim originalList As String, sheetName As String
If These_Two_Intersect(Target, "B2:B32") Then
    originalList = "B2:B32": sheetName = "Maandoverzicht ploeg 2"
ElseIf These_Two_Intersect(Target, "C2:C32") Then
    originalList = "C2:C32": sheetName = "Maandoverzicht ploeg 3"
ElseIf These_Two_Intersect(Target, "D2:D32") Then
    originalList = "D2:D32": sheetName = "Maandoverzicht ploeg 4"
Else:
    Exit Sub
End If

With Target
    .Interior.Color = Sheets(sheetName).Range(originalList).Interior.Color
    .Font.Color = Sheets(sheetName).Range(originalList).Font.Color
    .Font.Bold = Sheets(sheetName).Range(originalList).Font.Bold
End With

End Sub

Now, if you have to compare MANY "original lists" with Target, still use the small function (you will probably use it in other projects), but something like this is better:

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.CountLarge > 1) Or (Target.Value = "") Then Exit Sub

Dim str As String
str = "B2:B32,Maandoverzicht ploeg 2"
str = str & ",C2:C32,Maandoverzicht ploeg 3"
str = str & ",D2:C32,Maandoverzicht ploeg 4"
str = str & ",E2:C32,Maandoverzicht ploeg 5"
str = str & ",F2:C32,Maandoverzicht ploeg 6"
str = str & ",G2:C32,Maandoverzicht ploeg 7"
'.
'.
'.
str = str & ",ALL2:ALL32,Maandoverzicht ploeg 1000"

Dim compareList() As String
compareList = Split(str, ",")

Dim i As Integer
For i = 0 To UBound(compareList) Step 2
    If These_Two_Intersect(Target, compareList(i)) Then
        With Target
            .Interior.Color = Sheets(compareList(i + 1)).Range(compareList(i)).Interior.Color
            .Font.Color = Sheets(compareList(i + 1)).Range(compareList(i)).Font.Color
            .Font.Bold = Sheets(compareList(i + 1)).Range(compareList(i)).Font.Bold
        End With
    End If
Next i

End Sub

 

[prw79]

Hi.

Based on what you wrote, this is my best guess as to what you need.

Firstly, put this small function in a (any) standard VBA code module of your choice:
(Its purpose is to condense and make the code readable.)

Function These_Two_Intersect(range1 As Range, range2Address As String)
These_Two_Intersect = Not Intersect(range1, Range(range2Address)) Is Nothing
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.CountLarge > 1) Or (Target.Value = "") Then Exit Sub

Dim originalList As String, sheetName As String
If These_Two_Intersect(Target, "B2:B32") Then
    originalList = "B2:B32": sheetName = "Maandoverzicht ploeg 2"
ElseIf These_Two_Intersect(Target, "C2:C32") Then
    originalList = "C2:C32": sheetName = "Maandoverzicht ploeg 3"
ElseIf These_Two_Intersect(Target, "D2:D32") Then
    originalList = "D2:D32": sheetName = "Maandoverzicht ploeg 4"
Else:
    Exit Sub
End If

With Target
    .Interior.Color = Sheets(sheetName).Range(originalList).Interior.Color
    .Font.Color = Sheets(sheetName).Range(originalList).Font.Color
    .Font.Bold = Sheets(sheetName).Range(originalList).Font.Bold
End With

End Sub

Now, if you have to compare MANY "original lists" with Target, still use the small function (you will probably use it in other projects), but something like this is better:

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.CountLarge > 1) Or (Target.Value = "") Then Exit Sub

Dim str As String
str = "B2:B32,Maandoverzicht ploeg 2"
str = str & ",C2:C32,Maandoverzicht ploeg 3"
str = str & ",D2:C32,Maandoverzicht ploeg 4"
str = str & ",E2:C32,Maandoverzicht ploeg 5"
str = str & ",F2:C32,Maandoverzicht ploeg 6"
str = str & ",G2:C32,Maandoverzicht ploeg 7"
'.
'.
'.
str = str & ",ALL2:ALL32,Maandoverzicht ploeg 1000"

Dim compareList() As String
compareList = Split(str, ",")

Dim i As Integer
For i = 0 To UBound(compareList) Step 2
    If These_Two_Intersect(Target, compareList(i)) Then
        With Target
            .Interior.Color = Sheets(compareList(i + 1)).Range(compareList(i)).Interior.Color
            .Font.Color = Sheets(compareList(i + 1)).Range(compareList(i)).Font.Color
            .Font.Bold = Sheets(compareList(i + 1)).Range(compareList(i)).Font.Bold
        End With
    End If
Next i

End Sub

Wauw, Thanks! This is very helpful

 

[cmowla]

You're quite welcome. I tried.