How to create heat map on a table in SSRS? - sql

How can I create like this in SSRS? The color will change from red to green based on a value in a row (Underwriter). And all that in a group:

You can do this by right clicking on the individual cells and setting the fill colour based on an expression:
In the Image below I've mistakingly put "==" where it should be "="
To give you an example the following:
was created using the following expressions for the ID30, ID60 and ID90 fields respectively:
ID30:
=IIF(Fields!ID30.Value>="0" And Fields!ID30.Value<="100" ,"#c6c626",IIF(Fields!ID30.Value>="100" And Fields!ID30.Value<="200" ,"#c6c627",IIF(Fields!ID30.Value>="200","#9e2424","red")))
ID60:
=IIF(Fields!ID60.Value>="0" And Fields!ID60.Value<="100" ,"#c6c626",IIF(Fields!ID60.Value>="100" And Fields!ID60.Value<="200" ,"#c6c627",IIF(Fields!ID60.Value>="200","#9e2424","red")))
ID90:
=IIF(Fields!ID90.Value>="0" And Fields!ID90.Value<="100" ,"#c6c626",IIF(Fields!ID90.Value>="100" And Fields!ID90.Value<="200" ,"#c6c627",IIF(Fields!ID90.Value>="200","#9e2424","red")))

I came up with a way to get the color to actually be gradient, rather then based on nested IF statements. This method uses theoretical min and max values (you could set actual min and max values as variables if it is important that these are precise) and rgb integer values and results in a color hex code for SSRS.
Go to Report Properties>Code and paste in this function:
Public Function HeatMap(ByVal Value As Double _
, ByVal MinVal As Double _
, ByVal MaxVal As Double _
, ByVal RValLo As Double _
, ByVal GValLo As Double _
, ByVal BValLo As Double _
, ByVal RValHi As Double _
, ByVal GValHi As Double _
, ByVal BValHi As Double _
) As String
Dim DiffPercent As Double
Dim RNew As Integer
Dim GNew As Integer
Dim BNew As Integer
Dim HeatMapColor As String
If Value = Nothing Then
RNew = 255
GNew = 255
BNew = 255
ElseIf Value <= MinVal Then
RNew = RValLo
GNew = GValLo
BNew = BValLo
ElseIf Value >= MaxVal Then
RNew = RValHi
GNew = GValHi
BNew = BValHi
Else
DiffPercent = (Value - MinVal) / (MaxVal - MinVal)
RNew = RValLo - Round((RValLo - RValHi) * DiffPercent, 0)
GNew = GValLo - Round((GValLo - GValHi) * DiffPercent, 0)
BNew = BValLo - Round((BValLo - BValHi) * DiffPercent, 0)
End If
HeatMapColor = "#" & Hex(RNew) & Hex(GNew) & Hex(BNew)
HeatMap = HeatMapColor
End Function
Then in the cell where the heat map values are calculated, use the function in the background format expression, for example:
=Code.HeatMap(Sum(Fields!Orders.Value) / Sum(Fields!Orders.Value, "Tablix1"), 0, .2, 255, 255, 255, 99, 190, 123)
In this example, there are theoretical low and high values of 0 and .2 (0% and 20%) and the color will go between white on the low side and a green shade on the high side. Anything less than the min gets the min color and anything greater than the max gets the max color. This would also work if you want to go between two colors on the color wheel and if you wanted to go with something like red for negative values, white for zero, and green for positive values, you just use an IF statement and use the function twice, once for negative values and once for >= 0. Just substitute rgb values as necessary.

Related

How to automatically arrange shapes automatically drawn by loop?

I have a loop that generates rectangles automatically on a visio drawing but I need to have the script to arrange them automatically right know I recorded a macro while I rearranged the rectangles manually under the title box. But my rectangle count change constantly because the results from my if statement change constantly because my data continuously changes. I need for my loop to start drawing them under the title box in columns of six or seven rectangles.
For I = 1 To WS_Count
Set vsoShape =
Application.ActiveWindow.Page.Drop(Application.DefaultRectangleDataObject,
aoffset, boffset)
vsoShape.Text = ActiveWorkbook.Worksheets(I).Name
aoffset = aoffset
boffset = boffset + 0.75
Dev_Count = Dev_Count + 1
ActiveDocument.DiagramServicesEnabled = DiagramServices
Next I
I need to be able to set a starting position to begin dropping the rectangles below the title rectangle creating a new column every six to seven rectangles. Thanks
Increment aOffset every time I is divisible by the number of shapes you want horizontally...
You can do this with the Mod Operator If (iterator Mod runEveryXIterations = 0) Then ...
The example below should clarify the idea, the code is not exactly what you need but you should be able to grasp the idea:
Option Explicit
Public Sub printXY()
xyDistribute 10, 3, 0, 0, 0.75, 1.5
End Sub
Private Function xyDistribute(ByRef iterations As Long, _
ByRef newColAfter As Long, _
ByRef xPosInitial As Double, _
ByRef yPosInitial As Double, _
ByRef xStep As Double, _
ByRef yStep As Double)
Dim iter As Long
Dim xPos As Double
Dim yPos As Double
yPos = yPosInitial
xPos = xPosInitial
Debug.Print "xPos", "yPos"
For iter = 1 To iterations
Debug.Print xPos, yPos
' your code goes here
If (iter Mod newColAfter = 0) Then
yPos = yPos + yStep
xPos = xPosInitial
Else
xPos = xPos + xStep
End If
Next iter
End Function

SSRS Custom code error

I am using a custom code for text box background which I got here :
https://blogs.msdn.microsoft.com/davidlean/2009/02/16/sql-reporting-how-to-conditional-color-14-the-basics-report-expressions-custom-code/
However when I want to use it in an report expression I get a red error line under the function name. I am using Visual Studio and VB.NET.
What am i missing? I have pasted the code in the code under report properties.
Regards
EDIT :
I have used the following code as an expression : =code.ColorRYG(Fields!BlokkeklaarPersentGelewerKultAliasnaam.Value,Fields!BlokkeklaarmaksimumKultAliasnaam.Value,Fields!BlokkeklaarminimumKultAliasnaam.Value,0)
A red squigly line appears under ColorRYG. The code I have pasted (Report Properties Code) is as follows :
Public Function ColorRYG(ByVal Value As Decimal, ByVal MaxPositive As Decimal, ByVal MaxNegative As Decimal, ByVal Neutral As Decimal) As String
'Example: =code.ColorBack(expression, Max(expression), Min(expression), 0)
'=code.colorback( Fields!Sales.Value,max( Fields!Sales.Value),min( Fields!Sales.Value),0)
'Find Largest Range
Dim decRange As Decimal
Dim decPosRange As Decimal = Math.Abs(MaxPositive - Neutral)
Dim decNegRange As Decimal = Math.Abs(MaxNegative - Neutral)
decRange = IIf(decPosRange > decNegRange, decPosRange, decNegRange)
'Force color into Max-Min Range. Important if you want to Clip the color display to a subset of the data range.
Value = Switch((Value > MaxPositive), MaxPositive, Value < MaxNegative, MaxNegative, True, Value)
'Find Delta required to change color by 1/255th of a shade
Dim decColorInc As Decimal = 255 / decRange
'Find appropriate color shade
Dim iColor As Integer = CInt(Math.Round((Value - Neutral) * decColorInc))
'Return Appropriate +ve or -ve color
Dim strColor As String
If iColor >= 0 Then
'Green
iColor = 255 - iColor 'Thus 0 = White & 255 = Green
strColor = "#" & iColor.ToString("X2") & "FF00"
Else
'Red
iColor = iColor + 255 'NB iColour is -ve; -1 - -255
strColor = "#FF" & Math.Abs(iColor).ToString("X2") & "00"
End If
Return strColor
End Function
Thank you.

SSRS Report Builder 3.0: Conditional Formatting Gradient Color

I can find plenty of tutorials on how to use conditional formatting of tablix fields in Report Builder 3.0. However I would like a function that creates a gradient color, from black to red, which colors the text more and more red, the closer it comes to a certain number.
For example I got a column with the age of a product component in days. I want the text to be black (#000000), when the component is 0 days old. And then gradually turn into red, hitting a pure red (#FF0000) on the day it expires (could be day 30).
Can anyone provide me any information, regarding how to do that?
I ended up modifying the function from the solution linked by Alejandro.
Public Shared Function ColorDWB(ByVal Value As Decimal, ByVal MaxPositive As Decimal, ByVal Neutral As Decimal, ByVal ColStr As String) As String
'Initiate variables for Red, Green and Blue (RGB)
Dim ColVar1 As Integer
Dim ColVar2 As Integer
Dim ColVar3 As Integer
'Split the #RGB color to R, G, and B components
ColVar1=Convert.ToInt32(left(right(ColStr, 6),2),16)
ColVar2=Convert.ToInt32(left(right(ColStr, 4),2),16)
ColVar3=Convert.ToInt32(right(ColStr, 2),16)
'Find Largest Range
Dim decPosRange As Decimal = Math.Abs(MaxPositive - Neutral)
Dim iColor1 As Integer
Dim iColor2 As Integer
Dim iColor3 As Integer
Dim strColor As String
'Reduce a shade for each of the R,G,B components
iColor1 = Math.Max(0, Math.Min(ColVar1, ColVar1*(Value-Neutral)/(MaxPositive-Neutral)))
iColor2 = Math.Max(0, Math.Min(ColVar2, ColVar2*(Value-Neutral)/(MaxPositive-Neutral)))
iColor3 = Math.Max(0, Math.Min(ColVar3, ColVar3*(Value-Neutral)/(MaxPositive-Neutral)))
'Return the new color
strColor = "#" & iColor1.ToString("X2") & iColor2.ToString("X2") & iColor3.ToString("X2")
Return strColor
End Function
Like the answer before me, that article got me started but I modified to make it work better for my purposes.
Public Function HeatMap(ByVal Value As Double _
, ByVal MinVal As Double _
, ByVal MaxVal As Double _
, ByVal RValLo As Double _
, ByVal GValLo As Double _
, ByVal BValLo As Double _
, ByVal RValHi As Double _
, ByVal GValHi As Double _
, ByVal BValHi As Double _
) As String
Dim DiffPercent As Double
Dim RNew As Integer
Dim GNew As Integer
Dim BNew As Integer
Dim HeatMapColor As String
If Value = Nothing Then
RNew = 255
GNew = 255
BNew = 255
ElseIf Value <= MinVal Then
RNew = RValLo
GNew = GValLo
BNew = BValLo
ElseIf Value >= MaxVal Then
RNew = RValHi
GNew = GValHi
BNew = BValHi
Else
DiffPercent = (Value - MinVal) / (MaxVal - MinVal)
RNew = RValLo - Round((RValLo - RValHi) * DiffPercent, 0)
GNew = GValLo - Round((GValLo - GValHi) * DiffPercent, 0)
BNew = BValLo - Round((BValLo - BValHi) * DiffPercent, 0)
End If
HeatMapColor = "#" & Hex(RNew) & Hex(GNew) & Hex(BNew)
HeatMap = HeatMapColor
End Function
More info on my approach here: How to create heat map on a table in SSRS?

Force fit column of flexgrid

What is best way to force fit the columns of msflexgrid in vb6?
so, that all columns are visible and they occupies maximum width of grid!
I've tried this code but it does not properly fit last column inside the grid, can anyone suggest what could be problem?
Public Sub **FlexGrid_AutoSizeColumns (** ByRef pGrid As MSHFlexGrid, _
ByRef pForm As Form, _
Optional ByVal pIncludeHeaderRows As Boolean = True, _
Optional ByVal pAllowShrink As Boolean = True, _
Optional ByVal pMinCol As Long = 0, _
Optional ByVal pMaxCol As Long = -1, _
Optional ByVal pBorderSize As Long = 8, _
Optional fitToScreen As Boolean = False **)**
Dim lngMinCol As Long, lngMaxCol As Long, lngCurrRow As Long
Dim lngMinRow As Long, lngMaxRow As Long, lngCurrCol As Long
Dim lngMaxWidth As Long, lngCurrWidth As Long
Dim fntFormFont As StdFont
Dim totalWidth As Integer
totalWidth = 0
Set fntFormFont = New StdFont
Call CopyFont(pForm.Font, fntFormFont)
Call CopyFont(pGrid.Font, pForm.Font)
With pGrid
lngMinCol = pMinCol
lngMaxCol = IIf(pMaxCol = -1, .Cols - 1, pMaxCol)
lngMinRow = IIf(pIncludeHeaderRows, 0, .FixedRows)
lngMaxRow = .Rows - 1
For lngCurrCol = lngMinCol To lngMaxCol
lngMaxWidth = IIf(pAllowShrink, 0, pForm.ScaleX(.ColWidth(lngCurrCol), vbTwips, pForm.ScaleMode))
For lngCurrRow = lngMinRow To lngMaxRow '..find widest text (in scalemode of the form)
lngCurrWidth = pForm.TextWidth(Trim(.TextMatrix(lngCurrRow, lngCurrCol)))
If lngMaxWidth < lngCurrWidth Then lngMaxWidth = lngCurrWidth
Next lngCurrRow
lngMaxWidth = pForm.ScaleX(lngMaxWidth, pForm.ScaleMode, vbTwips)
.ColWidth(lngCurrCol) = lngMaxWidth + (pBorderSize * Screen.TwipsPerPixelX)
totalWidth = .ColWidth(lngCurrCol) + totalWidth
Next lngCurrCol
End With
Call CopyFont(fntFormFont, pForm.Font)
If fitToScreen = True Then
Dim i As Integer
Dim gridWidth As Long
gridWidth = pGrid.Width
For i = 0 To pGrid.Cols - 1
pGrid.ColWidth(i) = Int(gridWidth * pGrid.ColWidth(i) / totalWidth)
Next
End If
End Sub
One way I could think is to resize your columns (with visibility) to fit into the max width found in a column (text). The function returns either 0 or a double value. As long as the returned max column width is not zero, we may adjust the current grid column width accordingly. If zero then it remains the same.
Dim i, j, as Integer
Dim maxWidth as Double
For i = 0 to MsFlexGrid1.Rows - 1
For j = 0 to MsFlexGrid1.Cols - 1
maxWidth = maxColWidth(j)
If maxWidth > 0 then
MsFlexGrid.ColWidth(j) = maxWidth
End If
Next j
Next i
Private Function maxColWidth(coNum as Integer) as Double
Dim i, Max as Integer
Max = 0
With MsFlexGrid1
For i = .FixedRows to .Rows-1
If TextWidth(.TextMatrix(i, colNum)) > Max Then
Max = TextWidth(.TextMatrix(i, colNum))
End If
Next i
maxColWidth = Max
End With
End Function
to distribute the remaining space over the columns, divide it by the number of columns and add it to each column
'1 form with :
' 1 msflexgrid : name=MSFlexGrid1
Option Explicit
Private Sub Form_Load()
Dim intCol As Integer
'example form and grid configuration
Move 0, 0, 10000, 5000
With MSFlexGrid1
.FixedRows = 0
.FixedCols = 0
.Rows = 10
.Cols = 10
For intCol = 0 To .Cols - 1
.ColWidth(intCol) = (intCol + 1) * 107
Next intCol
End With 'MSFlexGrid1
End Sub
Private Sub Form_Resize()
MSFlexGrid1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub MSFlexGrid1_Click()
DistributeWidth
End Sub
Private Sub DistributeWidth()
Dim intCol As Integer, intColSel As Integer
Dim lngWidth As Long
Dim lngRemaining As Long
Dim lngExpand As Long
With MSFlexGrid1
intColSel = .Col 'remember selected column
.Col = 0 'select first column to ...
lngWidth = .Width - .CellLeft * 2 '... take flexgrid-borders into account
.Col = intColSel 'select column again
lngRemaining = lngWidth - InUse 'calculate the remaining space
If lngRemaining > 0 Then
lngExpand = lngRemaining \ .Cols 'distribute the remaining space over the columns
For intCol = 0 To .Cols - 1
.ColWidth(intCol) = .ColWidth(intCol) + lngExpand
Next intCol
lngExpand = lngRemaining Mod .Cols
.ColWidth(.Cols - 1) = .ColWidth(.Cols - 1) + lngExpand 'since we are working with longs, apply the remaining fraction to the last column
Else
'what to do with lack of space? Shrink columns or expand grid or nothing?
End If
End With 'MSFlexGrid1
End Sub
Private Function InUse() As Long
'calculate how much of the gridwidth is already in use by the columns
Dim intCol As Integer
Dim lngInUse As Long
With MSFlexGrid1
lngInUse = 0
For intCol = 0 To .Cols - 1
lngInUse = lngInUse + .ColWidth(intCol)
Next intCol
End With 'MSFlexGrid1
InUse = lngInUse
End Function
The above example somehow does not always fill the area completely, although i think the logic is correct and i can't see anything missing ...
i guess this gives a similar result to what you have? or is it slightly better?

Grouping and naming shapes in Excel with vba

In Excel vba, I am creating two shapes in excel using vba. An arrow, which I name "aro" + i, and a textbox, which I name "text" + i, where i is a number indicating the number of a photograph.
So, say for photograph 3 I will creat arrow "aro3" and textbox "text3".
I then want to group them and rename that group "arotext" + i, so "arotext3" in this instance.
So far I have been doing the grouping and renaming like this:
targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name)).Select
Selection.group
Selection.Name = "AroTxt" & Number
which works splendidly in a sub, but now I want to change this into a function and return the named group, so I tried something like this:
Dim arrowBoxGroup as Object
set arrowBoxGroup = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
arrowBoxGroup.group
arrowBoxGroup.Name = "AroTxt" & Number
I run into problems when I create a new group which has the same name as one which has already been created. So, if I create a second "aro3" and "text3" and then try to group them and rename the group to "arotext3" I get an error because a group with the same name is already present.
The thing I don't understand is that when I did this using the method referring to the selection, I could rename every group with the same name if I wanted and wouldn't get an error. Why does it work when referring to the Selection object, but fails when trying to use an assigned object?
UPDATE:
Since somebody asked, the code I have so far is below. arrow and textbox are an arrow and a textbox which point into a direction arbitrarily defined by the user using a form.
This then creates an arrow at the correct angle on the target worksheet and places a textbox with the specified number (also through the form) at the end of the arrow, so that it effectively forms a callout. I know that there are callouts, but they don't do what I want so I had to make my own.
I have to group the textbox and arrow because 1) they belong together, 2) I keep track of which callouts have already been placed using the group's name as a reference, 3) the user has to place the callout in the right location on a map which is embedded in the worksheet.
So far I have managed to make this into a function by making the return value a GroupObject. But this still relies on Sheet.Shapes.range().Select, which in my opinion is a very bad way of doing this. I am looking for a way which does not rely on the selection object.
And I would like to understand why this works when using selection, but fails when using strong typed variables to hold the objects.
Public Function MakeArrow(ByVal No As Integer, ByVal angle As Double, ByVal size As ArrowSize, ByVal ArrowX As Double, ByVal ArrowY As Double, ByVal TargetInternalAngle As Double, ByRef targetSheet As Worksheet) As GroupObject
Dim Number As String
Dim fontSize As Integer
Dim textboxwidth As Integer
Dim textboxheight As Integer
Dim arrowScale As Double
Dim X1 As Double
Dim Y1 As Double
Dim X2 As Double
Dim Y2 As Double
Dim xBox As Double
Dim yBox As Double
Dim testRange As Range
Dim arrow As Shape
Dim textBox As Shape
' Dim arrowTextbox As ShapeRange
' Dim arrowTextboxGroup As Variant
Select Case size
Case ArrowSize.normal
fontSize = fontSizeNormal
arrowScale = arrowScaleNormal
Case ArrowSize.small
fontSize = fontSizeSmall
arrowScale = arrowScaleSmall
Case ArrowSize.smaller
fontSize = fontSizeSmaller
arrowScale = arrowScaleSmaller
End Select
arrowScale = baseArrowLength * arrowScale
'Estimate required text box width
Number = Trim(CStr(No))
Set testRange = shtTextWidth.Range("A1")
testRange.value = Number
testRange.Font.Name = "MS P明朝"
testRange.Font.size = fontSize
shtTextWidth.Columns(testRange.Column).EntireColumn.AutoFit
shtTextWidth.Columns(testRange.row).EntireRow.AutoFit
textboxwidth = testRange.Width * 0.8
textboxheight = testRange.Height * 0.9
testRange.Clear
'Make arrow
X1 = ArrowX
Y1 = ArrowY
X2 = X1 + arrowScale * Cos(angle)
Y2 = Y1 - arrowScale * Sin(angle)
Set arrow = AddArrow(X1, Y1, X2, Y2, Number, targetSheet)
'Make text box
Set textBox = Addtextbox(angle, Number, fontSize, X2, Y2, textboxwidth, textboxheight, TargetInternalAngle, targetSheet)
'Group arrow and test box
targetSheet.shapes.Range(Array(arrow.Name, textBox.Name)).group.Select
Selection.Name = "AroTxt" & Number
Set MakeArrow = Selection
' Set arrowTextbox = targetSheet.shapes.Range(Array(arrow.Name, textBox.Name))
' Set arrowTextboxGroup = arrowTextbox.group
' arrowTextboxGroup.Name = "AroTxt" & Number
'
' Set MakeArrow = arrowTextboxGroup
End Function
Private Function AddArrow(ByVal StartX As Double, ByVal StartY As Double, ByVal EndX As Double, ByVal EndY As Double, ByVal Number As String, ByRef targetSheet As Worksheet) As Shape
Set AddArrow = targetSheet.shapes.AddLine(StartX, StartY, EndX, EndY)
With AddArrow
.Name = "Aro" & Number
With .Line
.BeginArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadLength = msoArrowheadLengthMedium
.BeginArrowheadWidth = msoArrowheadWidthMedium
.ForeColor.RGB = RGB(0, 0, 255)
End With
End With
End Function
Private Function Addtextbox(ByVal angle As Double, ByVal Number As String, ByVal fontSize As Integer, ByVal arrowEndX As Double, ByVal arrowEndY As Double, ByVal Width As Integer, ByVal Height As Integer, ByVal LimitAngle As Double, ByRef targetSheet As Worksheet) As Shape
Dim xBox, yBox As Integer
Dim PI As Double
Dim horizontalAlignment As eTextBoxHorizontalAlignment
Dim verticalAlignment As eTextBoxVerticalAlignment
PI = 4 * Atn(1)
If LimitAngle = 0 Then
LimitAngle = PI / 4
End If
Select Case angle
'Right
Case 0 To LimitAngle, 2 * PI - LimitAngle To 2 * PI
xBox = arrowEndX
yBox = arrowEndY - Height / 2
horizontalAlignment = eTextBoxHorizontalAlignment.left
verticalAlignment = eTextBoxVerticalAlignment.Center
'Top
Case LimitAngle To PI - LimitAngle
xBox = arrowEndX - Width / 2
yBox = arrowEndY - Height
horizontalAlignment = eTextBoxHorizontalAlignment.Middle
verticalAlignment = eTextBoxVerticalAlignment.Bottom
'Left
Case PI - LimitAngle To PI + LimitAngle
xBox = arrowEndX - Width
yBox = arrowEndY - Height / 2
horizontalAlignment = eTextBoxHorizontalAlignment.Right
verticalAlignment = eTextBoxVerticalAlignment.Center
'Bottom
Case PI + LimitAngle To 2 * PI - LimitAngle
xBox = arrowEndX - Width / 2
yBox = arrowEndY
horizontalAlignment = eTextBoxHorizontalAlignment.Middle
verticalAlignment = eTextBoxVerticalAlignment.top
End Select
Set Addtextbox = targetSheet.shapes.Addtextbox(msoTextOrientationHorizontal, xBox, yBox, Width, Height)
With Addtextbox
.Name = "Txt" & Number
With .TextFrame
.AutoMargins = False
.AutoSize = False
.MarginLeft = 0#
.MarginRight = 0#
.MarginTop = 0#
.MarginBottom = 0#
Select Case verticalAlignment
Case eTextBoxVerticalAlignment.Bottom
.verticalAlignment = xlVAlignBottom
Case eTextBoxVerticalAlignment.Center
.verticalAlignment = xlVAlignCenter
Case eTextBoxVerticalAlignment.top
.verticalAlignment = xlVAlignTop
End Select
Select Case horizontalAlignment
Case eTextBoxHorizontalAlignment.left
.horizontalAlignment = xlHAlignLeft
Case eTextBoxHorizontalAlignment.Middle
.horizontalAlignment = xlHAlignCenter
Case eTextBoxHorizontalAlignment.Right
.horizontalAlignment = xlHAlignRight
End Select
With .Characters
.Text = Number
With .Font
.Name = "MS P明朝"
.FontStyle = "標準"
.size = fontSize
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End With
.Fill.Visible = msoFalse
.Fill.Solid
.Fill.Transparency = 1#
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.style = msoLineSingle
.Transparency = 0#
.Visible = msoFalse
End With
End With
End Function
Range.Group returns a value. You might try:
Set arrowBoxRange = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
Set arrowBoxGroup = arrowBoxRange.Group
arrowBoxGroup.Name = "AroTxt" & Number
I suspect that the current Selection gets updated as if the following in your earlier work:
Set Selection = Selection.Group 'it's as if this is done for you when you create the group.
which is causing the difference.
FYI, I'm using Excel 2010 and cannot duplicate the original code snippet based on Selection (I get an error doing "Selection.Name = ", which gives object does not support property.)
Ok, I can get this to work:
Selection.Group.Select
Selection.Name = "AroTxt"
Of course, like the other snippet I suggest, this reassigns the group's return value, so that Selection in Selection.Group and Selection.Name are referring to different objects, which I think is what you want.
It is because you are storing the new groups as an object manually now that this error has appeared. You probably are not able to do anything with the multiple instances of "AroTxt" & Number that you have created. As excel wouldn't be able to decide which group you mean.
Excel shouldn't allow this but it doesn't always warn that this has happened but will error if you try to select a group that has a duplicate name.
Even if this isn't the case, it isn't good practice to have duplicate variable names. Would it not be better to add the extra Arrow's and textBox's to the group?
So to solve your problem you will have to check to see if the group already exists before you save it. Maybe delete it if exists or add to the group.
Hope this helps
Edit: As it always seems to go, the error started popping up after I clicked submit. I'll tinker around a bit more, but will echo #royka in wondering if you really do need to give the same name to multiple shapes.
The below code seems to do what you're looking for (create the shapes, give them names and then group). In the grouping function, I left the "AroText" number the same just to see if an error would happen (it did not). It seems that both shapes have the same name, but what differentiates them is their Shape.ID. From what I can tell, if you say ActiveSheet.Shapes("My Group").Select, it will select the element with that name with the lowest ID (as to why it lets you name two things the same name, no clue :) ).
It isn't quite an answer to your question of "why" (I wasn't able to replicate the error), but this will hopefully give you one way "how".
Sub SOTest()
Dim Arrow As Shape
Dim TextBox As Shape
Dim i as Integer
Dim Grouper As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
' Make two shapes and group, naming the group the same in both cases
For i = 1 To 2
' Create arrow with name "Aro" & i
Set Arrow = ws.Shapes.AddShape(msoShapeRightArrow, 10, 50, 30, 30)
Arrow.Name = "Aro" & i
' Create text box with name "Text" & i
Set TextBox = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 50, 40, 40)
TextBox.Name = "Text" & i
' Use a group function to rename the shapes
Set Grouper = CreateGroup(ws, Arrow, TextBox, i)
' See the identical names but differing IDs
Debug.Print "Name: " & Grouper.Name & " | ID: " & Grouper.ID
Next
End Sub
Function CreateGroup(ws As Worksheet, Arrow As Shape, TextBox As Shape, Number As Integer) As Variant
Dim arrowBoxGroup As Variant
' Group the provided shapes and change the name
Set arrowBoxGroup = ws.Shapes.Range(Array(Arrow.Name, TextBox.Name)).Group
arrowBoxGroup.Name = "AroTxt" & Number
' Return the grouped object
Set CreateGroup = arrowBoxGroup
End Function