根据EXCEL文件各数据表结构定义中创建ER图实体对象

最新推荐文章于 2024-07-02 17:45:52 发布

niulity

最新推荐文章于 2024-07-02 17:45:52 发布

阅读量5.4k

点赞数

分类专栏： VBA 文章标签： excel each 脚本文档

本文链接：https://blog.csdn.net/NcFire/article/details/4276478

版权

VBA 专栏收录该内容

5 篇文章 0 订阅

订阅专栏

原创：牛超

2008-06-17

OSAKA

又要整理EXCEL文档了。。。

如题，遍历EXCEL各SHEET（表定义），创建实体对象（框图），设置字体与间距。

脚本如下：

Option Explicit

Private Sub CommandButton1_Click()
createRects
End Sub

Private Sub createRects()
Dim stitle As String
Dim slayout As String
Dim scontent As String
Dim scur As String
Dim sdesc As String
Dim slabel As String
Dim myshape As Shape
Dim ws As Worksheet
Dim irow As Integer

Dim trgws As Excel.Worksheet
Dim cx, cy, rwh, rht, wthlmt, maxht As Single

cx = 10
cy = 50
rwh = 200
rht = 200
wthlmt = 1500
maxht = 0

Set trgws = ThisWorkbook.Worksheets(1)

For Each myshape In trgws.Shapes
    If myshape.AutoShapeType = msoShapeRectangle Then
        myshape.Delete
    End If
Next

    For Each ws In ThisWorkbook.Worksheets
        If ws.Index > 1 Then
            scontent = ""
            slabel = ""

            slayout = ws.Name
            stitle = ws.Cells(1, 1)

            For irow = 3 To 200
                scur = ws.Cells(irow, 1)

                If Len(Trim(scur)) = 0 Then
                    Exit For
                End If

                sdesc = ws.Cells(irow, 6)
                If InStr(LCase(sdesc), LCase("index:idx01")) Then
                    scontent = scontent & "・" & scur & Chr(10)
                End If
            Next

            slabel = "【" & stitle & "】" & slayout & Chr(10) & scontent
            Set myshape = trgws.Shapes.AddShape(msoShapeRectangle, cx, cy, rwh, rht)
            myshape.Select

            'With myshape.TextFrame
            '    .Characters.Text = slabel
            '    .HorizontalAlignment = xlHAlignLeft
            '    .VerticalAlignment = xlVAlignCenter
            'End With

            Selection.Characters.Text = slabel
            Selection.Characters.Font.Name = "ＭＳ明朝"
            Selection.Characters.Font.Size = 9

            Selection.AutoSize = True
            If Selection.Height > maxht Then
                maxht = Selection.Height
            End If

            cx = cx + Selection.Width + 20
            If cx > wthlmt Then
                cx = 10
                cy = cy + maxht + 20
            End If
        End If
    Next

End Sub