PDA

View Full Version : [SOLVED] Insert cell content in shapes VBA



elmoum
04-03-2017, 03:15 AM
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
04-04-2017, 01:20 PM
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
04-04-2017, 01:50 PM
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
04-04-2017, 05:09 PM
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
04-04-2017, 11:12 PM
@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
04-05-2017, 01:58 AM
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
04-05-2017, 02:16 AM
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
04-05-2017, 02:48 AM
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
04-05-2017, 03:43 AM
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
04-05-2017, 03:52 AM
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
04-05-2017, 04:16 AM
Show off! :bow:

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
04-05-2017, 05:18 AM
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
04-05-2017, 05:33 AM
Not with my code.

elmoum
04-05-2017, 05:43 AM
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
04-05-2017, 06:33 AM
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
04-05-2017, 06:40 AM
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
04-05-2017, 07:38 AM
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
04-05-2017, 08:13 AM
Hello paul,

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

cheers

mdmackillop
04-05-2017, 08:23 AM
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
04-05-2017, 12:10 PM
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

Paul_Hossler
04-05-2017, 12:12 PM
Hello paul,

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

cheers


Thanks, but I'm not a pro (far from it)

It's usually a team effort

There are a lot of very talented people who hang out here and do this stuff for a living