excel矩阵数据怎么绘制线条
时间:2022-11-07 09:58:44
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
![](/images/zang.png)
![](/images/jiucuo.png)
猜你喜欢
Win10ltsc和Win10ltsb都有什么区别?Win10ltsc和Win10ltsb区别介绍
![](https://img.aspxhome.com/file/2023/9/49179_0s.jpg)
Excel表格中同时添加柱状图和折线图的操作方法
WPS2012艺术字的实用操作技巧
![](https://img.aspxhome.com/file/2023/1/a164841_0s.png)
excel2003拆分窗口的教程
win10realtek高清晰音频管理器在哪?win10realtek高清晰音频管理器设置教程
![](https://img.aspxhome.com/file/2023/6/47776_0s.jpg)
Excel中Randbetween函数的使用方法是什么
Excel人民币小写金额转换大写技巧
在excel2003中如何将字体设置成别的颜色?
![](https://img.aspxhome.com/file/2023/3/41283_0s.jpg)
你知道如何在Word中输入特殊的数字吗?
在word文档中怎么绘制简单的表格?
![](https://img.aspxhome.com/file/2023/2/24512_0s.jpg)
Excel2007基础教程:把工作表窗口拆分为几个窗格
Excel 如何批量新建工作簿并保存成指定的文件名
![](https://img.aspxhome.com/file/2023/2/55142_0s.gif)
使用Excel表格快速分离姓名和手机号码的方法
iOS 15.6.1 验证通道已关闭,iOS 16还能降级吗?
![](https://img.aspxhome.com/file/2023/1/45121_0s.png)
受益终身 Office中Word十技巧
Excel2003如何实现字符替换
如何在excel中导入记事本中的数据
![](https://img.aspxhome.com/file/2023/5/38205_0s.jpg)
word2013怎样设置纸张大小
![](https://img.aspxhome.com/file/2023/9/17919_0s.jpg)
使用Text函数在Excel2013中建立不会间断的顺序编号
word公式编辑器在哪里?怎么用?
![](https://img.aspxhome.com/file/2023/0/33670_0s.jpg)