Question

我正在尝试遍历“有序”列表，以层次结构样式创建几个矩形形状（并将它们与弯头连接器链接）。示例：在我的WBS数据表中，我有以下内容

     A              B
1    0.        Box 0. lvl1
2    0.1.      Box 0.1. lvl2
3              Comment 1
4              Comment 2
5    0.1.1.    Box 0.1.1. lvl3
6              Comment 1
7              Comment 2
8              Comment 3
9    0.2.      Box 0.2. lvl2
10   0.2.1.    Box 0.2.1. lvl3
11   0.2.2.    Box O.2.1. lvl3
12             Comment 1
13             Comment 2
14   1.        Box 1. lvl1
15             Comment 1
16             Comment 2
17   1.1.      Box 1.1. lvl2

将在WBS工作表上输出如下内容：

基本上，请阅读A列中的“索引”，如果它是第一级（A列中为2个字符），则绘制一个蓝色框并从B列中写入相应的值，然后查看下面的行（如果它是一个水平） 2个框（4个字符），在下方绘制（左侧短一点），为其指定值；相同的lvl 3盒。如果A列为空，请在形状下方创建一个文本框，然后添加所有注释。

到目前为止（请参见下面的代码），我设法创建了一个框（是），对其进行了样式设置并添加了文本，还创建了一个文本框（在侧面有一条线，如图所示，但我需要它与文本框具有相同的“动态”高度），但我无法添加所有注释。我无法理解它需要移动到下一个“级别”（例如从蓝色框转到绿色框）的魔力。

我还没有尝试将每个盒子都连接到它的“层次上级”，但这是另一个故事：）

我很确定我没有正确管理变量（主要是计数器），无法在正确的时间重置变量，等等...

有什么提示可以向我发送正确的消息吗？

Public Sub wbsShape()


Dim wbs, wbsdata As Worksheet
Set wbs = ThisWorkbook.Sheets("WBS")
Set wbsdata = ThisWorkbook.Sheets("WBSdata")

i = 2 'counter, because data starts on line 2
ileft = 100 'initial position from left of sheet
itop = 100 'initial position from top of sheet
lg = 175 'main box width
ht = 50 'main box height
ind = 10 'indent (for lines, or smaller boxes)
impred = RGB(128, 0, 0) 'red
impgreen = RGB(0, 128, 0) 'green
impblue = RGB(0, 0, 128) 'blue
impgrey = RGB(200, 200, 200) 'light grey for border
black = RGB(0, 0, 0)
white = RGB(255, 255, 255)

Do While Not IsEmpty(wbsdata.Cells(i, "A").Value)

With wbs.Shapes.AddShape(msoShapeRectangle, ileft, itop, lg, ht)
    .Fill.ForeColor.RGB = impblue
    .Line.ForeColor.RGB = impgrey
    .Line.Weight = 1
    .Name = wbsdata.Cells(i, "B").Value
    With .TextFrame
            With .Characters
                    .Text = UCase(wbsdata.Cells(i, "B").Value)
                    With .Font
                            .Color = white
                            .Name = "Arial"
                            .Size = 14
                            .FontStyle = "Bold"
                    End With
            End With
                 .HorizontalAlignment = xlHAlignCenter
                 .VerticalAlignment = xlVAlignCenter
      End With

   End With

i = i + 1

    If IsEmpty(wbsdata.Cells(i, "A").Value) Then
    wbs.Shapes.AddLine(ileft + ind, itop + ht, ileft + ind, itop + ht + 100).Line.ForeColor.RGB = RGB(10, 10, 10)
        With wbs.Shapes.AddTextbox(msoTextOrientationHorizontal, ileft + 2 * ind, itop + ht, lg - ind, 30)
             .Line.Visible = msoFalse
             .Fill.Transparency = 1
            With .TextFrame.Characters
                .Font.Name = "Arial"
                .Text = wbsdata.Cells(i, "B").Value
            End With
    End With

End If

itop = itop + ht + 20

Loop

End Sub

Answer 1

我认为这将需要很多工作（我已经去除了很多格式），但这也许会使您朝着正确的方向入手。

Sub x()

Dim r As Range, v, s As Shape
ileft = 100 'initial position from left of sheet
itop = 100 'initial position from top of sheet
lg = 175 'main box width
ht = 50 'main box height
ind = 10 'indent (for lines, or smaller boxes)
impred = RGB(128, 0, 0) 'red
impgreen = RGB(0, 128, 0) 'green
impblue = RGB(0, 0, 128) 'blue
impgrey = RGB(200, 200, 200) 'light grey for border
black = RGB(0, 0, 0)
white = RGB(255, 255, 255)

For Each r In Range("A1:A4")
    v = Split(r, ".")
    If UBound(v) = 1 Then
        Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ileft, itop, lg, ht)
        s.Fill.ForeColor.RGB = impblue
        s.TextFrame.Characters.Text = r.Offset(, 1)
        itop = itop + 75
    ElseIf UBound(v) = 2 Then
        Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ileft, itop, lg, ht)
        s.Fill.ForeColor.RGB = impgreen
        s.TextFrame.Characters.Text = r.Offset(, 1)
        itop = itop + 75
    ElseIf r = vbNullString Then
        Set s = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ileft + 2 * ind, itop + ht, lg - ind, 30)
        s.Line.Visible = msoFalse
        s.Fill.Transparency = 1
        With s.TextFrame.Characters
            .Font.Name = "Arial"
            .Text = r.Offset(, 1).Value
        End With
        itop = itop + 75
    End If
Next r

End Sub

Excel VBA：从列表创建形状层次结构

1 个答案: