excel矩陣數據怎么繪制線條
Q：如下所示，左側是一個4行4列的數值矩陣，要使用VBA根據這些數值繪制右側的圖形。
繪制規則是這樣的：找到最小的數值（忽略），將其與第2小的數值用點劃線連接，再將第2小的數值與第3小的數值用點劃線連接，依此類推，直到連接到最大的數值。在連接的過程中，遇到不連接，如果兩個要連接的數值之間有其他數，則從這些數值上直接跨過。如所示，連接的順序是1-2-3-4-5-6-7-8-9-1 -11-12-13。
A：VBA代碼如下：
‘在Excel中使用VBA連接單元格中的整數
‘輸入: 根據實際修改rangeIN和rangeOUT變量
‘ ? ? ?rangeIN – 包括數字矩陣的單元格區域
‘ ? ? ?rangeOUT – 輸出區域左上角單元格
Sub ConnectNumbers()
Dim rangeINAs Range, rangeOUT As Range
Dim cellPrev As Range
Dim cellNext As Range
Dim cell AsRange
Dim i AsInteger
Dim arrRange() As Variant
Set rangeIN= Range(“B3:E6”)
Set rangeOUT = Range(“H3”)
‘刪除工作表中已繪制的形狀
DeleteArrows
ReDim arrRange( )
‘在一維數組中存儲單元格區域中所有大于的整數
For Each cell In rangeIN
Ifcell.Value > And _
IsNumeric(cell.Value) And _
cell.Value = Int(cell.Value) Then
‘僅存儲整數
ReDim Preserve arrRange(i)
arrRange(i) = cell.Value
i =i + 1
End If
Next cell
‘排序數組(使用冒泡排序)
Call BubbleSort(arrRange)
‘遍歷數組,找到單元格區域相應單元格
For i =LBound(arrRange) To UBound(arrRange) – 1
Set cellPrev = rangeIN.Find(arrRange(i), _
LookIn:=xlValues, LookAt:=xlWhole)
Set cellNext = rangeIN.Find(arrRange(i + 1), _
LookIn:=xlValues, LookAt:=xlWhole)
‘rangeOUT相對于rangeIN合適的偏離來繪制形狀
Call DrawArrows(cellPrev.Offset( _
rangeOUT(1, 1).Row – rangeIN(1, 1).Row, _
rangeOUT(1, 1).Column – rangeIN(1, 1).Column), _
cellNext.Offset(rangeOUT(1, 1).Row – rangeIN(1, 1).Row, _
rangeOUT(1, 1).Column – rangeIN(1, 1).Column))
Next i
End Sub
‘冒泡排序法
Sub BubbleSort(MyArray() As Variant)
‘從小到大排序
Dim i As Long, j As Long
Dim Temp As Variant
For i =LBound(MyArray) To UBound(MyArray) – 1
For j =i + 1 To UBound(MyArray)
If MyArray(i) > MyArray(j) Then
Temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = Temp
End If
Next j
Next i
End Sub
‘從一個單元格中心繪制到另一個單元格中心的線條
Private Sub DrawArrows(FromRange As Range, ToRange As Range)
Dim dleft1 As Double, dleft2 As Double
Dim dtop1 As Double, dtop2 As Double
Dim dheight1 As Double, dheight2 As Double
Dim dwidth1As Double, dwidth2 As Double
dleft1 =FromRange.Left
dleft2 =ToRange.Left
dtop1 =FromRange.Top
dtop2 =ToRange.Top
dheight1 =FromRange.Height
dheight2 =ToRange.Height
dwidth1 =FromRange.Width
dwidth2 =ToRange.Width
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
dleft1+ dwidth1 / 2, dtop1 + dheight1 / 2, _
dleft2+ dwidth2 / 2, dtop2 + dheight2 / 2).Select
‘格式化線條
With Selection.ShapeRange.Line
.BeginArrowheadStyle = msoArrowheadOval
.EndArrowheadStyle = msoArrowheadOval
.DashStyle = msoLineDash
.Weight= 1.75
.ForeColor.RGB = RGB( , , )
End With
End Sub
‘刪除所有形狀
Sub DeleteArrows()
Dim shp AsShape
For Each shp In ActiveSheet.Shapes
If shp.Connector = msoTrue Then
shp.Delete
End If
Next shp
End Sub
