'主程序
Sub blockChart()
Dim arr '数据源
Dim total As Double '总和
Dim have As Double '还剩
Dim newBlock As Double '新的子块
Dim otherBlock As Double '其它子块
Dim l, t, w, h, i, j, txt, shpName()
Call init
With Selection
l = .Left: t = .Top: w = .Width: h = .Height
End With
arr = Range("a1").CurrentRegion
Call SelectionSort1(arr) '可选
total = Application.Sum(Application.Index(arr, 0, 2)): have = total
For i = 2 To UBound(arr)
newBlock = w * h * arr(i, 2) / have
otherBlock = w * h - newBlock
txt = arr(i, 1) & Format(arr(i, 2) / total, " 0%")
If i Mod 2 Then
't,h变
h = newBlock / w
Call addShp(l, t, w, h, txt)
t = t + h
h = otherBlock / w
Else
'l,w变
w = newBlock / h
Call addShp(l, t, w, h, txt)
l = l + w
w = otherBlock / h
End If
have = have - arr(i, 2)
j = j + 1: ReDim Preserve shpName(j): shpName(j) = ActiveSheet.Shapes(j).Name
Next i
ActiveSheet.Shapes.Range(shpName).Group
End Sub
'初始化
Sub init()
If Workbooks.Count = 0 Then End
If Selection.Count = 1 Then End
If TypeName(Selection) <> "Range" Then End
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
Application.Calculate
End Sub
'添加图形
Sub addShp(l, t, w, h, txt)
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, l, t, w, h)
With shp
.Line.Visible = msoFalse
.Fill.ForeColor.RGB = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
.TextFrame2.TextRange.Characters.Text = txt
' .TextFrame2.TextRange.Font.Name = "微软雅黑"
' .TextFrame2.TextRange.Font.Size = 14
' .TextFrame2.HorizontalAnchor = msoAnchorCenter
' .TextFrame2.VerticalAnchor = msoAnchorMiddle
' .ThreeD.BevelTopType = msoBevelCircle
' .ThreeD.BevelTopInset = 8
' .ThreeD.BevelTopDepth = 12
End With
Set shp = Nothing
End Sub
'排序
Sub SelectionSort1(arr)
Dim i&, j&, k&
For i = LBound(arr) To UBound(arr) - 1
k = i
For j = i + 1 To UBound(arr)
If arr(k, 2) < arr(j, 2) Then k = j '降序
Next j
If k <> i Then Call swap(arr(k, 1), arr(i, 1)): Call swap(arr(k, 2), arr(i, 2))
Next i
End Sub
'互换
Sub swap(x, y)
Dim z
z = x: x = y: y = z
End Sub
IP卡
狗仔卡
发表于 2016-4-10 13:37
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
抢沙发
千斤顶
显身卡
楼主
