excelnoob192
New Member
- Joined
- Sep 2, 2024
- Messages
- 1
- Office Version
- 2021
Hello everyone,
I am still quite inexperienced in Excel VBA and have encountered a problem. The background:
I would like to fill various shapes with small rectangles (‘modules’). The modules should always be the same size and their size is predefined. A minimum distance between the modules and to the edge of the respective shape is also specified. Taking these conditions into account, as many modules as possible should be generated symmetrically in the shape. The size of the mould should be variable so that the maximum number of modules can always be generated.
This is not a problem with a rectangular shape (see ‘Sheet1’ and sub ‘GenerateModulesSquare’.
Next, I tried my hand at a trapezoid. I first determined the 4 corner points of the trapezoid to determine the edges. I then used a loop to query whether there was room for another module + two safety distances to the edge (see subs ‘TrapezoidTooManyModules’ and ‘TrapezoidNotEnoughModules’).
Especially with ‘TrapezoidNotEnoughModules’ I don't understand why gaps are left where there would actually be enough space for further modules.
‘TrapezoidTooManyModules’ looks better at first glance, but exceeds the edges of the trapezoid.
Depending on whether you enlarge or reduce the size of the trapezoid, the malfunction becomes clearer. Neither of the two approaches works.
I suspect that I am not calculating the left and right edges accurately and therefore the If queries are correct, but have the wrong basis.
I would be very grateful for any advice!
Attached are the three subs mentioned and 3 pictures:
Greetings
I am still quite inexperienced in Excel VBA and have encountered a problem. The background:
I would like to fill various shapes with small rectangles (‘modules’). The modules should always be the same size and their size is predefined. A minimum distance between the modules and to the edge of the respective shape is also specified. Taking these conditions into account, as many modules as possible should be generated symmetrically in the shape. The size of the mould should be variable so that the maximum number of modules can always be generated.
This is not a problem with a rectangular shape (see ‘Sheet1’ and sub ‘GenerateModulesSquare’.
Next, I tried my hand at a trapezoid. I first determined the 4 corner points of the trapezoid to determine the edges. I then used a loop to query whether there was room for another module + two safety distances to the edge (see subs ‘TrapezoidTooManyModules’ and ‘TrapezoidNotEnoughModules’).
Especially with ‘TrapezoidNotEnoughModules’ I don't understand why gaps are left where there would actually be enough space for further modules.
‘TrapezoidTooManyModules’ looks better at first glance, but exceeds the edges of the trapezoid.
Depending on whether you enlarge or reduce the size of the trapezoid, the malfunction becomes clearer. Neither of the two approaches works.
I suspect that I am not calculating the left and right edges accurately and therefore the If queries are correct, but have the wrong basis.
I would be very grateful for any advice!
Attached are the three subs mentioned and 3 pictures:
VBA Code:
Sub GenerateModulesSquare()
Dim roofShape As Shape
Dim moduleShape As Shape
Dim moduleWidth As Single, moduleHeight As Single
Dim clearance As Single
Dim xPosLeft As Single, xPosRight As Single, yPos As Single
Dim centerX As Single, roofBottom As Single
Dim moduleNumber As Integer
Dim xPosStart As Single
Dim spaceLeft As Single, spaceRight As Single
' Set the roof shape (existing shape on the worksheet)
Set roofShape = ThisWorkbook.Sheets("Sheet1").Shapes("RoofShape") ' Adjust the name of the roof shape
' Set module size (width and height) and clearance
moduleWidth = 30 ' Width of the module
moduleHeight = 50 ' Height of the module
clearance = 5
moduleNumber = 1
' Calculate the center of the roof shape and the bottom edge
centerX = roofShape.Left + (roofShape.width / 2)
roofBottom = roofShape.Top + roofShape.height - clearance
' Starting point for y (begin from the top)
yPos = roofShape.Top + clearance
' Starting position for x in the center
xPosStart = centerX - (moduleWidth / 2)
' Generate modules symmetrically from the center
Do While yPos + moduleHeight <= roofBottom
' Place modules to the left of the center
xPosLeft = xPosStart
spaceLeft = centerX - roofShape.Left
Do While xPosLeft >= roofShape.Left + clearance
Set moduleShape = ThisWorkbook.Sheets("Sheet1").Shapes.AddShape(msoShapeRectangle, xPosLeft, yPos, moduleWidth, moduleHeight)
moduleShape.Name = "Module_" & moduleNumber
moduleShape.TextFrame2.TextRange.Text = "Module" & moduleNumber
FormatModule moduleShape
moduleNumber = moduleNumber + 1
xPosLeft = xPosLeft - moduleWidth - clearance
Loop
' Place modules to the right of the center
xPosRight = xPosStart + moduleWidth + clearance
spaceRight = roofShape.Left + roofShape.width - xPosRight
Do While spaceRight >= moduleWidth + clearance
Set moduleShape = ThisWorkbook.Sheets("Sheet1").Shapes.AddShape(msoShapeRectangle, xPosRight, yPos, moduleWidth, moduleHeight)
moduleShape.Name = "Module_" & moduleNumber
moduleShape.TextFrame2.TextRange.Text = "Module" & moduleNumber
FormatModule moduleShape
moduleNumber = moduleNumber + 1
xPosRight = xPosRight + moduleWidth + clearance
spaceRight = spaceRight - moduleWidth - clearance
Loop
' Calculate the next y-position (move down)
yPos = yPos + moduleHeight + clearance
' Reset xPos to the left side
xPosStart = centerX - (moduleWidth / 2)
Loop
End Sub
VBA Code:
Sub TrapezoidTooManyModules()
Dim ws As Worksheet
Dim shp As Shape
Dim moduleWidth As Single, moduleHeight As Single
Dim clearance As Single
Dim xPos As Single, yPos As Single
Dim moduleNumber As Integer
Dim trapezoidTopLeftX As Single, trapezoidTopLeftY As Single
Dim trapezoidTopRightX As Single, trapezoidTopRightY As Single
Dim trapezoidBottomLeftX As Single, trapezoidBottomLeftY As Single
Dim trapezoidBottomRightX As Single, trapezoidBottomRightY As Single
Dim m1 As Double, b1 As Double, m2 As Double, b2 As Double
Dim xLeftLimit As Single, xRightLimit As Single
Dim midX As Single
' Set worksheet (Sheet2)
Set ws = ThisWorkbook.Sheets("Sheet2")
' Set trapezoid shape
Set shp = ws.Shapes("TrapezoidShape")
' Set module size (moduleWidth & moduleHeight) and clearance (clearance)
moduleWidth = 30
moduleHeight = 50
clearance = 5
moduleNumber = 1
' Calculate trapezoid coordinates
trapezoidTopLeftX = shp.Left + ((shp.width - (shp.width * (1 - shp.Adjustments(1)))) / 2)
trapezoidTopLeftY = shp.Top
trapezoidTopRightX = trapezoidTopLeftX + (shp.width * (1 - shp.Adjustments(1)))
trapezoidTopRightY = shp.Top
trapezoidBottomLeftX = shp.Left
trapezoidBottomLeftY = shp.Top + shp.height
trapezoidBottomRightX = shp.Left + shp.width
trapezoidBottomRightY = shp.Top + shp.height
' Calculate slopes (m) and intercepts (b) of the left and right edges
m1 = (trapezoidBottomLeftY - trapezoidTopLeftY) / (trapezoidBottomLeftX - trapezoidTopLeftX)
b1 = trapezoidTopLeftY - m1 * trapezoidTopLeftX
m2 = (trapezoidBottomRightY - trapezoidTopRightY) / (trapezoidBottomRightX - trapezoidTopRightX)
b2 = trapezoidTopRightY - m2 * trapezoidTopRightX
' Start from the middle of the top row
yPos = trapezoidTopLeftY + clearance
' Generate modules from top to bottom and from the center to the left and right
Do While yPos + moduleHeight + clearance <= trapezoidBottomLeftY
' Calculate the x-limits for the current y-position
xLeftLimit = (yPos - b1) / m1 + clearance
xRightLimit = (yPos - b2) / m2 - clearance
' Start from the center
midX = (xLeftLimit + xRightLimit) / 2
xPos = midX - moduleWidth / 2
' Generate modules to the right
Do While xPos + moduleWidth <= xRightLimit
If xPos + moduleWidth <= xRightLimit Then
Set shpModule = ws.Shapes.AddShape(msoShapeRectangle, xPos, yPos, moduleWidth, moduleHeight)
shpModule.Name = "Module_" & moduleNumber
shpModule.TextFrame2.TextRange.Text = "Module" & moduleNumber
moduleNumber = moduleNumber + 1
End If
xPos = xPos + moduleWidth + clearance
Loop
' Start from the center
xPos = midX - moduleWidth / 2 - (moduleWidth + clearance)
' Generate modules to the left
Do While xPos >= xLeftLimit
If xPos >= xLeftLimit Then
Set shpModule = ws.Shapes.AddShape(msoShapeRectangle, xPos, yPos, moduleWidth, moduleHeight)
shpModule.Name = "Module_" & moduleNumber
shpModule.TextFrame2.TextRange.Text = "Module" & moduleNumber
moduleNumber = moduleNumber + 1
End If
xPos = xPos - (moduleWidth + clearance)
Loop
' Move to the next row
yPos = yPos + moduleHeight + clearance
Loop
End Sub
VBA Code:
Sub TrapezoidNotEnoughModules()
Dim ws As Worksheet
Dim shp As Shape
Dim moduleWidth As Single, moduleHeight As Single
Dim clearance As Single
Dim xPos As Single, yPos As Single
Dim moduleNumber As Integer
Dim trapezoidTopLeftX As Single, trapezoidTopLeftY As Single
Dim trapezoidTopRightX As Single, trapezoidTopRightY As Single
Dim trapezoidBottomLeftX As Single, trapezoidBottomLeftY As Single
Dim trapezoidBottomRightX As Single, trapezoidBottomRightY As Single
Dim m1 As Double, b1 As Double, m2 As Double, b2 As Double
Dim xLeftLimit As Single, xRightLimit As Single
Dim midX As Single
' Set worksheet (Sheet2)
Set ws = ThisWorkbook.Sheets("Sheet2")
' Set background shape (Trapezoid)
Set shp = ws.Shapes("TrapezoidShape")
' Set module size (moduleWidth & moduleHeight) and clearance (clearance)
moduleWidth = 30
moduleHeight = 50
clearance = 5
moduleNumber = 1
' Calculate trapezoid coordinates
trapezoidTopLeftX = shp.Left + ((shp.width - (shp.width * (1 - shp.Adjustments(1)))) / 2)
trapezoidTopLeftY = shp.Top
trapezoidTopRightX = trapezoidTopLeftX + (shp.width * (1 - shp.Adjustments(1)))
trapezoidTopRightY = shp.Top
trapezoidBottomLeftX = shp.Left
trapezoidBottomLeftY = shp.Top + shp.height
trapezoidBottomRightX = shp.Left + shp.width
trapezoidBottomRightY = shp.Top + shp.height
' Calculate slopes (m) and intercepts (b) of the left and right edges
m1 = (trapezoidBottomLeftY - trapezoidTopLeftY) / (trapezoidBottomLeftX - trapezoidTopLeftX)
b1 = trapezoidTopLeftY - m1 * trapezoidTopLeftX
m2 = (trapezoidBottomRightY - trapezoidTopRightY) / (trapezoidBottomRightX - trapezoidTopRightX)
b2 = trapezoidTopRightY - m2 * trapezoidTopRightX
' Start from the middle of the top row
yPos = trapezoidTopLeftY + clearance
' Generate modules from top to bottom and from the center to the left and right
Do While yPos + moduleHeight + clearance <= trapezoidBottomLeftY
' Calculate the x-limits for the current y-position
xLeftLimit = (yPos - b1) / m1 + clearance
xRightLimit = (yPos - b2) / m2 - clearance
' Start from the center
midX = (xLeftLimit + xRightLimit) / 2
xPos = midX - moduleWidth / 2
' Generate modules to the right
Do While xPos + moduleWidth / 2 <= xRightLimit
' Check if there is enough space for another module
If (xRightLimit - (xPos + moduleWidth) >= moduleWidth + 2 * clearance) Then
Set shpModule = ws.Shapes.AddShape(msoShapeRectangle, xPos, yPos, moduleWidth, moduleHeight)
shpModule.Name = "Module_" & moduleNumber
shpModule.TextFrame2.TextRange.Text = "Module" & moduleNumber
moduleNumber = moduleNumber + 1
Else
Exit Do ' If there is not enough space, exit the loop for placing modules to the right
End If
xPos = xPos + moduleWidth + clearance
Loop
' Start from the center
xPos = midX - moduleWidth / 2 - (moduleWidth + clearance)
' Generate modules to the left
Do While xPos >= xLeftLimit
' Check if there is enough space for another module
If ((xPos - xLeftLimit) >= moduleWidth + 2 * clearance) Then
Set shpModule = ws.Shapes.AddShape(msoShapeRectangle, xPos, yPos, moduleWidth, moduleHeight)
shpModule.Name = "Module_" & moduleNumber
shpModule.TextFrame2.TextRange.Text = "Module" & moduleNumber
moduleNumber = moduleNumber + 1
Else
Exit Do ' If there is not enough space, exit the loop for placing modules to the left
End If
xPos = xPos - (moduleWidth + clearance)
Loop
' Move to the next row
yPos = yPos + moduleHeight + clearance
Loop
End SubGreetings
Attachments
Last edited by a moderator:
