excel矩陣數據在工作表中繪制線條？

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

版權聲明：本文內容由網絡用戶投稿，版權歸原作者所有，本站不擁有其著作權，亦不承擔相應法律責任。如果您發現本站中有涉嫌抄襲或描述失實的內容，請聯系我們jiasou666@gmail.com 處理，核實后本網站將在24小時內刪除侵權內容。

版權聲明：本文內容由網絡用戶投稿，版權歸原作者所有，本站不擁有其著作權，亦不承擔相應法律責任。如果您發現本站中有涉嫌抄襲或描述失實的內容，請聯系我們jiasou666@gmail.com 處理，核實后本網站將在24小時內刪除侵權內容。