VBA cyklus for

[Lima]

Dear all,

I have problem with matching two columns - I need to color regions in czech republic, due tu value (1-8) in another column... I have some macro, but I don´t know, how to assign each (right) rows together...

could you please help?

Private Sub Worksheet_Change(ByVal Target As Range)
For Target.Address =  "$AA$5" To "$AA$68" '(values)
For X = "$X$5" To "$X$68" 'name of regions (shapes)
Select Case Target.Value
        Case Is = 1
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 2
                        
        Case Is = 2
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 3
            
        Case Is = 3
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 4
            
        Case Is = 4
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 5
        
        Case Is = 5
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 6
            
        Case Is = 6
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 7
            
         Case Is = 7
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 16
            
         Case Is = 8
            ActiveSheet.Shapes("X").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 25
                        
    End Select
Next X
Next Y
End Sub

This one is working, but I have to do it more than 50 times..
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = "$AA$26" Then
    Select Case Target.Value
        Case Is = 1
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 2
        Case Is = 2
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 3
        Case Is = 3
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 4
         Case Is = 4
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 5
        Case Is = 5
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 6
        Case Is = 6
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 7
        Case Is = 7
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 16
        Case Is = 8
            ActiveSheet.Shapes("Okres_CH").Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 25
      End Select
      
End If

End Sub

Thank you very very much!!!

Lima

 

[capparfrank]

I think you need something like this:

Private Sub Worksheet_Change(ByVal Target As Range)
 
    For rowCtr = 5 To 68
    
    Select Case Range("$AA$" & rowCtr).Value
        Case Is = 1
            ActiveSheet.Shapes(Range("$X$" & rowCtr).Value).Select
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 2
                            
           '
           '
           '  do each case
           '
           '
           
        End Select
    Next rowCtr
End Sub