Insert cell content in shapes VBA

[elmoum]

hello everyone,


am looking for help!! am working on a project of data projection. I creat a map and linked it to a table (as shown in the worksheet). the map containes states
i used VBA in order to color code the map. i want now to show the numbers in the table on the map automatically. am able to do it with formula, ex: select shape, =A2 but the problem is that the table is not fixed it can change.
could you plz help me


thank you in advance
regards

[mancubus]

welcome to the forum.
you don't need any named ranges and additional tables etc.
insert values in G2:G7 into D2: D7.
and run the code below.

Sub vbax_59069_color_shapes_based_on_corresponding_value()

    Dim i As Long, colRank As Long

    For i = 2 To 12
        colRank = Application.Match(Range("B" & i), Range("D1:D15"), 1)
        ActiveSheet.Shapes(Range("A" & i).Value).Select
        Selection.ShapeRange.Fill.ForeColor.RGB = Range("D" & colRank).Interior.Color
    Next i
    
    Range("A1").Select

End Sub

see attached file.

[mdmackillop]

Very neat, but you can avoid the selection

    For i = 2 To 12
        colRank = Application.Match(Range("B" & i), Range("D1:D15"), 1)
        ActiveSheet.Shapes(Range("A" & i).Value).Fill.ForeColor.RGB = Range("D" & colRank).Interior.Color
    Next i

[Paul_Hossler]

Since the table might change with more areas, you can make the macro a little more automated.

I don't like hard coding ranges, and since I'd probably make a typo on one of the areas, I added a little error message to avoid a debug message

Option Explicit

Sub vbax_59069_color_shapes_based_on_corresponding_value()
    Dim r As Range
    Dim i As Long, colRank As Long
    Dim oShape As Shape
    With ActiveSheet
        Set r = .Cells(1, 1).CurrentRegion
        For i = 2 To r.Rows.Count
            colRank = Application.Match(.Range("B" & i), .Range("D:D"), 1)
            
            Set oShape = Nothing
            On Error Resume Next
            Set oShape = .Shapes(.Range("A" & i).Value)
            On Error GoTo 0
            
            If oShape Is Nothing Then
                MsgBox "Couldn't find " & .Range("A" & i).Value
            Else
                oShape.Fill.ForeColor.RGB = .Range("D" & colRank).Interior.Color
            End If
        Next I
    End With
End Sub

[mancubus]

@md
somehow this did not work for me during testing.
i had to change it to Selection.

actually it was a oneliner.

ActiveSheet.Shapes(Range("A" & i).Value).Fill.ForeColor.RGB = Range("D" & Application.Match(Range("B" & i), Range("D1:D15"), 1)).Interior.Color

[elmoum]

hello and thank you for your help;

Am afraid you didn't understant quite what i wanted to do I didn't make it clear.I tried your codes and they work very well BUT My need now is to SHOW the NUMBERS on each state, for example the state of BORDJ EL KIFFAN sales is 784.50 so what i want is to show this number along with the color on the shape of BORDJ EL KIFFAN. could it be done?

thank you again for your help

[elmoum]

hello everyone and thank you for your help;

Am afraid you didn't understant quite what i wanted to do I didn't make it clear.I tried your codes and they work very well BUT My need now is to SHOW the NUMBERS on each state, for example the state of BORDJ EL KIFFAN sales is 784.50 so what i want is to show this number along with the color on the shape of BORDJ EL KIFFAN. could it be done?

thank you again for your help
Attached the file with an example on worksheet "example"

[mdmackillop]

This uses the sample from Post #2

Option Explicit


Sub vbax_59069()
    Dim r As Range
    Dim i As Long, colRank As Long
    Dim oShape As Shape
    Dim w, x, y, z, Data
    Dim shp
    
    With ActiveSheet
        For Each shp In .Shapes
            If Left(shp.Name, 5) = "TextB" Then shp.Delete
        Next
    
        Set r = .Cells(1, 1).CurrentRegion


        For i = 2 To r.Rows.Count
            colRank = Application.Match(.Range("B" & i), .Range("D:D"), 1)
            Set oShape = Nothing
            On Error Resume Next
            Set oShape = .Shapes(.Range("A" & i).Value)
            With oShape
                w = .Top: x = .Left: y = .Height: z = .Width: Data = Range("B" & i).Value
            End With
            On Error GoTo 0


            If oShape Is Nothing Then
                MsgBox "Couldn't find " & .Range("A" & i).Value
            Else
                oShape.Fill.ForeColor.RGB = .Range("D" & colRank).Interior.Color
            End If
            Call AddText(w, x, y, z, Data)


        Next i
    End With


End Sub


Sub AddText(w, x, y, z, Data)
    Dim Lft, Tp
    Dim Tb
    Lft = x + z / 2 - 20
    Tp = w + y / 2 - 6
    Set Tb = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Lft, Tp, 40, 12)
     With Tb
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
        With .TextFrame2
            .TextRange.Characters.Text = Round(Data, 1)
            .MarginTop = 0
        End With
    End With
End Sub

[elmoum]

My God!!!!
thank you a lot..... that's awsome maaaan!! I wish one day i could be a PRO like you!!! thank you mdmackillop
My boss is gonna be soooo happy

[snb]

Sub M_snb()
  sn = Feuil4.Cells(1).CurrentRegion
  sp = Feuil4.Cells(2, 4).CurrentRegion.Columns(1)
  
  For j = 2 To UBound(sn)
    Feuil4.Shapes(sn(j, 1)).TextFrame2.TextRange.Text = Int(sn(j, 2))
    Feuil4.Shapes(sn(j, 1)).Fill.BackColor.RGB = Feuil4.Cells(1, 4).Offset(Application.Match(sn(j, 2), sp, 1)).Interior.Color
  Next
End Sub

[mdmackillop]

Show off!

To add names as well, using SNB's code

Feuil3.Shapes(sn(j, 1)).TextFrame2.TextRange.Text = sn(j, 1) & vbCr & Int(sn(j, 2))

[elmoum]

hi
I just want to thank you for your help on the Excel forum "insert cell content on a map"
However, i came accross an isue; it works very well the numbers are copied automatically on the map but when i synchronize the table an synchronize the map the previous number remains on the map
could you help me plz!
thank you in advance

[snb]

Not with my code.

[elmoum]

Not with my code.

could you please send my workbook with hyour code because i didn't understand where to copie and past the code

[snb]

This subforum is a 'help' forum, not a 'solutions' forum.
You should be able to apply the suggestions we make in your own situation/worknook. Otherwise it looks more like an assignment to be paid for.

[elmoum]

Hello,

Sorry for the missunderstanding
to make things clear am a VBA Newbi, that means the codes you have given me are like chinese for me.
mdmackillop has given me help and it was great but something was missing (as it's mentioned on comment #12)
So please don't misunderstand me because i just need help.

thank you in advance

[Paul_Hossler]

This uses the sample from Post #2

Nice - small suggestion ... since people tend to throw TextBoxes around with wild abandon, maybe using .AlternativeText as a 'marker' instead of relying on the 'TextB' part of the name

Option Explicit
 
 
Sub vbax_59069()
    Dim r As Range
    Dim i As Long, colRank As Long
    Dim oShape As Shape
    Dim w As Long, x As Long, y As Long, z As Long, Data As Double
    Dim shp
     
    With ActiveSheet
        For Each shp In .Shapes
            If shp.Type = msoTextBox Then
                If shp.AlternativeText = "Data" Then
                    shp.Delete
                End If
            End If
        Next
         
        Set r = .Cells(1, 1).CurrentRegion
         
         
        For i = 2 To r.Rows.Count
            colRank = Application.Match(.Range("B" & i), .Range("D:D"), 1)
            Set oShape = Nothing
            On Error Resume Next
            Set oShape = .Shapes(.Range("A" & i).Value)
            With oShape
                w = .Top: x = .Left: y = .Height: z = .Width: Data = Range("B" & i).Value
            End With
            On Error GoTo 0
             
             
            If oShape Is Nothing Then
                MsgBox "Couldn't find " & .Range("A" & i).Value
            Else
                oShape.Fill.ForeColor.RGB = .Range("D" & colRank).Interior.Color
            End If
            Call AddText(w, x, y, z, Data)
             
             
        Next i
    End With
     
     
End Sub
 
 
Sub AddText(w As Long, x As Long, y As Long, z As Long, Data As Double)
    Dim Lft As Double, Tp As Double
    Dim Tb As Shape
    Lft = x + z / 2 - 20
    Tp = w + y / 2 - 6
    Set Tb = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Lft, Tp, 40, 12)
    With Tb
        .AlternativeText = "Data"
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
        With .TextFrame2
            .TextRange.Characters.Text = Round(Data, 1)
            .MarginTop = 0
        End With
    End With
End Sub

[elmoum]

Hello paul,

thank you for your help....it works!
hope i'll be PRO like you one day

cheers

[mdmackillop]

Hi Paul
Thanks for the suggestion. I've never worked much with shapes, but I think SNB has the solution here; textboxes are not required as the values can be added to the shape directly.
Malcolm

[Paul_Hossler]

Hi Paul
Thanks for the suggestion. I've never worked much with shapes, but I think SNB has the solution here; textboxes are not required as the values can be added to the shape directly.
Malcolm

Yea -- I learned something.

Only problem might be if you needed to manually adjust the position of the text from its standard positioning to fit in an irregular shape or to move it outside if it doesn't fit/overlaps

IMVHO, the textbox approach might have more flexibility at the expense of complexity