excel - 根据单元格数据调整形状大小

Question

我想根据单元格数据调整矩形的形状，矩形的高度（宽度）是恒定的，长度根据单元格引用而变化。

对于 EG（请参考图片）：DW1 是起始侧，它应该具有来自范围（“B13”）的参考数据并沿着或匹配数据到范围（“D4：AF4”），并且对于另一端 DW2 应该相同。DW2 应该具有来自范围（“C13”）的引用并将数据匹配到范围（“D4：AF4”）。

我已经处理了一些代码，但它没有正确的输出。

请在下面查看我的代码。

新代码也会有所帮助

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

标签： excelvba

Answer 1

我不确定我是否 100% 理解了你的观点，但看看我的处理方法：

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

结果如下所示：

希望它会帮助你:)