Creating Dynamic Shapes in Excel Macro

aroig07

New Member
Joined
Feb 26, 2019
Messages
35
Hello !!!! I have this code which creates a module based on values put in excel columns. Basically, I have the name of a division on column 2, an actual number of employees on column 3, a calculated need of employees on column 4, and the difference on column 5 which the box changes colors depending on the division between the actual and difference. It works perfectly as is and gives me exactly what I need, but I wanted to add another 2 columns which represent overtime (column 6) and the difference taking into account overtime (column 7). I am able to show the values in the boxes, but it is not formatting the overtime difference based on the colors like the difference in column 4. Here is my code, I was basically just replicating the same code for the OT gap but was not working. I have highlighted in blue the portions I added to my original code.

Sub readData()


Dim lastParent As Integer


Dim rowIndex As Integer
Dim colIndex As Integer
Dim rowLoc As Integer
Dim colPosBox As Integer
Dim boxcolor As String
Dim boxcolorH As String
boxcolorH = ""

rowLoc = 50
rowIndex = 2
lastParent = 50
Dim actualColumnIndex As Integer
Dim calculatedColumnIndex As Integer
Dim gapColumnIndex As Integer
Dim overtimeColumnIndex As Integer
Dim gapOTColumnIndex As Integer

colIndex = 1

Do While ThisWorkbook.Sheets("Data").Cells(1, colIndex).Value <> ""
If (ThisWorkbook.Sheets("Data").Cells(1, colIndex).Value = "ACTUAL") Then
actualColumnIndex = colIndex
ElseIf (ThisWorkbook.Sheets("Data").Cells(1, colIndex).Value = "CALCULATED") Then
calculatedColumnIndex = colIndex
ElseIf (ThisWorkbook.Sheets("Data").Cells(1, colIndex).Value = "GAP") Then
gapColumnIndex = colIndex
ElseIf (ThisWorkbook.Sheets("Data").Cells(1, colIndex).Value = "Overtime") Then
overtimeColumnIndex = colIndex
ElseIf (ThisWorkbook.Sheets("Data").Cells(1, colIndex).Value = "GAP OT") Then
gapOTColumnIndex = colIndex
End If
colIndex = colIndex + 1
Loop


Do While ThisWorkbook.Sheets("Data").Cells(rowIndex, 2).Value <> ""

If (ThisWorkbook.Sheets("Data").Cells(rowIndex, 1).Value = "PARENT") Then
lastParent = rowLoc
boxcolorH = "LIGHTB"
boxcolor = "LIGHTB"
Call createItems(boxcolorH, 10, rowLoc, 100, 25, Worksheets("Data").Cells(rowIndex, 2).text)
Else
boxcolorH = ""
boxcolor = ""
Call createItems(boxcolorH, 20, rowLoc, 100, 25, Worksheets("Data").Cells(rowIndex, 2).text)
End If

Call createItems(boxcolorH, 140, rowLoc, 75, 25, Worksheets("Data").Cells(rowIndex, 3).text)

colIndex = 4
colPosBox = 260
Do While ThisWorkbook.Sheets("Data").Cells(rowIndex, colIndex).Value <> ""

If (colIndex = gapColumnIndex) Then
If (Worksheets("Data").Cells(rowIndex, actualColumnIndex).Value <> 0) Then
NumberC = Abs(Worksheets("Data").Cells(rowIndex, gapColumnIndex).Value) / Worksheets("Data").Cells(rowIndex, actualColumnIndex).Value
Else
NumberC = 1
End If

If (NumberC > 0.3) Then
boxcolorH = "RED"
ElseIf (NumberC > 0.15) Then
boxcolorH = "YELLOW"
Else
boxcolorH = "GREEN"
End If
Else
boxcolorH = boxcolor
End If

Call createItems(boxcolorH, colPosBox, rowLoc, 75, 25, Worksheets("Data").Cells(rowIndex, colIndex).text)

colPosBox = colPosBox + 100
colIndex = colIndex + 1
Loop

Do While ThisWorkbook.Sheets("Data").Cells(rowIndex, colIndex).Value <> ""

If (colIndex = gapOTColumnIndex) Then
If (Worksheets("Data").Cells(rowIndex, actualColumnIndex).Value <> 0) Then
NumberO = Abs(Worksheets("Data").Cells(rowIndex, gapOTColumnIndex).Value) / Worksheets("Data").Cells(rowIndex, actualColumnIndex).Value
Else
NumberO = 1
End If

If (NumberO > 0.3) Then
boxcolorH = "RED"
ElseIf (NumberO > 0.15) Then
boxcolorH = "YELLOW"
Else
boxcolorH = "GREEN"
End If
Else
boxcolorH = boxcolor
End If

Call createItems(boxcolorH, colPosBox, rowLoc, 75, 25, Worksheets("Data").Cells(rowIndex, colIndex).text)

colPosBox = colPosBox + 100
colIndex = colIndex + 1
Loop

Set var1 = Worksheets("Output").Shapes.AddConnector(msoConnectorStraight, 15, rowLoc + (25 / 2), colIndex * 65, _
rowLoc + (25 / 2))

With var1.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
var1.ZOrder msoSendToBack

If (rowIndex = 2) Then
rowLoc = rowLoc + 5
End If
rowLoc = rowLoc + 30
rowIndex = rowIndex + 1

If (ThisWorkbook.Sheets("Data").Cells(rowIndex, 1).Value = "PARENT" Or ThisWorkbook.Sheets("Data").Cells(rowIndex, 2).Value = "") Then
Set var1 = Worksheets("Output").Shapes.AddConnector(msoConnectorStraight, 15, lastParent + (25 / 2), 15, _
rowLoc + (25 / 2) - 30)
var1.ZOrder msoSendToBac
With var1.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
var1.ZOrder msoSendToBack
rowLoc = rowLoc + 80
End If

Loop


End Sub



Here is the code also for the createitems sub:

Sub createItems(color As String, locX As Integer, locY As Integer, x As Integer, y As Integer, itemText As String)
' .Select
Set var1 = Worksheets("Output").Shapes.AddShape(msoShapeRectangle, locX, locY, x, y)
var1.ZOrder msoSendToFront
If (color = "RED") Then
With var1.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With

ElseIf (color = "YELLOW") Then
With var1.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
.Solid
End With

ElseIf (color = "GREEN") Then
With var1.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
ElseIf (color = "LIGHTB") Then
With var1.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(231, 240, 245)
.Transparency = 0
.Solid
End With
Else
With var1.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.6000000238
.Transparency = 0
.Solid
End With

End If

With var1.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
var1.TextFrame2.TextRange.Characters.text = itemText
var1.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
With var1.TextFrame2.TextRange.Characters. _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With var1.TextFrame2.TextRange.Characters.Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
With var1.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
End Sub
 

Some videos you may like

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Watch MrExcel Video

Forum statistics

Threads
1,109,359
Messages
5,528,220
Members
409,809
Latest member
VICKRAM

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top