CODEWITHSUNDEEP
excelvba
Akshay
Akshay

Reputation: 21

Resize shape according to cell data

I want to resize the shape of rectangle according to cell data, were height(width) of rectangle is constant and length changes according to cell References.

For EG (please refer image) : DW1 is starting side which should have Reference data from range("B13") and move along or match data to range("D4:AF4") and it should be same for another end side DW2. DW2 should have reference from range("C13") and match data to range("D4:AF4").

enter image description here

I have worked on some code but it is not having proper output.

Please have a look for my code below.

new code will also be helpfull

Sub Rectanglematch()
Dim dl1 As Double
Dim dl2 As Double
Dim dw1 As Double
Dim dw2 As Double
Dim dw As Double
Dim dl As Double
Dim d As Date
Dim R As Excel.Range

dw = dw1
dw = dw2
dl = dl1
dl = dl2

d = CDate(Sheets("Tabelle1").Range("b13"))
Set R = Sheets("Tabelle1").Range("d4:AF4")
dl1 = 10 * Range("A1").Value
dl2 = 10 * Range("A1").Value

dw1 = Application.WorksheetFunction.Match(CDbl(CDate(Sheets("Tabelle1").Range("b13"))), R, 0)
dw2 = Application.WorksheetFunction.Match(CDbl(CDate(Sheets("Tabelle1").Range("c13"))), R, 0)
With ActiveSheet.Shapes("Rechteck 2")
        .Top = .Top - dw + .Height
        .Height = dw
        .Width = dl
End With

End Sub

Upvotes: 1

Views: 850

Answers (1)

Teamothy
Teamothy

Reputation: 2016

I'm not really sure if I got your point in 100%, but take a look at my approach to this:

Option Explicit

Sub Rectanglematch()

Dim lastRow As Long
Dim lastCol As Long
Dim heightCell As Long
Dim widthCell As Long
Dim rngDates As Range
Dim i As Long
Dim sDat As Long
Dim eDat As Long
Dim myRectangle As Shape

With ThisWorkbook.Sheets("Tabelle1")

    lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
    lastCol = .Cells(4, Columns.Count).End(xlToLeft).Column

    For i = 6 To lastRow

        If .Cells(i, 2) = "" Or .Cells(i, 3) = "" Then

        Else
            heightCell = .Cells(i, 2).RowHeight
            widthCell = .Cells(i, 2).Width

            Set rngDates = .Range(.Cells(4, 4), .Cells(4, lastCol))

            sDat = Application.WorksheetFunction.Match(.Cells(i, 2), rngDates, 0) + 3
            eDat = Application.WorksheetFunction.Match(.Cells(i, 3), rngDates, 0) + 3

            Set myRectangle = .Shapes.AddShape(msoShapeRectangle, .Cells(i, sDat).Left, .Cells(i, sDat).Top, .Cells(i, eDat).Left - .Cells(i, sDat).Left, heightCell)
        End If
    Next i

End With

End Sub

And the result looks like this:

enter image description here

Hope it will help You :)

Upvotes: 1

Related Questions