VBA Loop Sub Through Range

[daveasu]

I have a state map of counties made up of custom shapes in Excel to display individual county populations. Excel updates the color and text with county name and population on each shape. The shape names on the map match the county names. The text boxes are named “countyname text”.

County names are in a60:a134
Populations are in b60:b134

I can run this on individual counties, but is there a way to loop this through the range of cells that have the county and population data?

I’m brand new to VBA – this may not be best programming practices below.

ashland is the first county name. It's population is in B60

Sub populationmap()

Dim ashland As Integer
 
ashland = Worksheets("population").Range("$b$60").Value

Select Case ashland

Case 1 To 9
    Sheets("population").Shapes("ashland").Fill.ForeColor.RGB = RGB(50, 205, 50)
    Sheets("population").Shapes("ashland text").Fill.ForeColor.RGB = RGB(50, 205, 50)
Case 10 To 80
    Sheets("population").Shapes("ashland").Fill.ForeColor.RGB = RGB(238, 122, 233)
    Sheets("population").Shapes("ashland text").Fill.ForeColor.RGB = RGB(238, 122, 233)
Case 81 To 499
    Sheets("population").Shapes("ashland").Fill.ForeColor.RGB = RGB(99, 184, 255)
    Sheets("population").Shapes("ashland text").Fill.ForeColor.RGB = RGB(99, 184, 255)
Case 500 To 15000
    Sheets("population").Shapes("ashland").Fill.ForeColor.RGB = RGB(255, 242, 0)
    Sheets("population").Shapes("ashland text").Fill.ForeColor.RGB = RGB(255, 242, 0)
Case Else
    Sheets("population").Shapes("ashland").Fill.ForeColor.RGB = RGB(255, 255, 255)
    Sheets("population").Shapes("ashland text").Fill.ForeColor.RGB = RGB(255, 255, 255)
 
End Select
 
county = Worksheets("population").Range("$a$60").Text
 
Sheets("population").Shapes("ashland text").Select
 
ashland = Worksheets("population").Range("$b$60").Value
 
If ashland > 0 Then
 
    Selection.Characters.Text = county & Chr(12) & ashland
 
Else: Selection.Characters.Text = county

WrapText = False

horizontalalighment = xlGeneral

End If

End Sub

 

[Tinbendr]

Not tested.

Sub populationmap2()

Dim wsPopl As Worksheet
Dim CName As Range 'County name
 
Set wsPopl = Worksheets("population")
With wsPopl
    For Each CName In .Range("A60:A134")
        Select Case CName.Offset(, 1).Value 'get value of +1 column of Countyname
        
        Case 1 To 9
            .Shapes(CName.Value).Fill.ForeColor.RGB = RGB(50, 205, 50)
            .Shapes(CName.Value & " text").Fill.ForeColor.RGB = RGB(50, 205, 50)
        Case 10 To 80
            .Shapes(CName.Value).Fill.ForeColor.RGB = RGB(238, 122, 233)
            .Shapes(CName.Value & " text").Fill.ForeColor.RGB = RGB(238, 122, 233)
        Case 81 To 499
            .Shapes(CName.Value).Fill.ForeColor.RGB = RGB(99, 184, 255)
            .Shapes(CName.Value & " text").Fill.ForeColor.RGB = RGB(99, 184, 255)
        Case 500 To 15000
            .Shapes(CName.Value).Fill.ForeColor.RGB = RGB(255, 242, 0)
            .Shapes(CName.Value & " text").Fill.ForeColor.RGB = RGB(255, 242, 0)
        Case Else
            .Shapes(CName.Value).Fill.ForeColor.RGB = RGB(255, 255, 255)
            .Shapes(CName.Value & " text").Fill.ForeColor.RGB = RGB(255, 255, 255)
         
        End Select
         
        If CName.Offset(, 1).Value > 0 Then
            With .Shapes(CName.Value & " text")
                .Text = CName.Value & Chr(12) & CName.Value
                .WrapText = False
                .horizontalalighment = xlGeneral
            End With
         
        Else
            With .Shapes(CName.Value & " text")
                .Text = CName.Value
                .WrapText = False
                .horizontalalighment = xlGeneral
            End With
        
        End If
    Next
End With
End Sub

 

[daveasu]

Thank you! Thank you!!

Worked like a charm!