excel矩阵数据在工作表中绘制线条?

时间:2022-11-26 11:20:01 

Q如下所示,左侧是一个4行4列的数值矩阵,要使用VBA根据这些数值绘制右侧的图形。

excel矩阵数据在工作表中绘制线条?

绘制规则是这样的:找到最小的数值(忽略),将其与第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

标签:excel常用函数,excel常见问题,excel技巧,Excel教程
0
投稿

猜你喜欢

  • 京东金融怎么进行提现?京东金融进行提现的教程

    2022-08-04 20:37:16
  • 为WinXP系统制作钥匙盘开机时必须插入钥匙盘才能进入系统

    2023-12-25 07:08:01
  • 电脑开机屏幕界面无法启动的故障排除

    2022-11-09 18:52:29
  • XP系统如何隐藏桌面图标

    2022-11-11 14:40:12
  • 但是工作表的保护设置

    2022-06-03 00:10:48
  • win10什么时候发售 win10发售时间和售价介绍

    2023-06-16 11:23:37
  • 谷歌浏览器怎么截图

    2023-04-03 08:29:38
  • Excel 利用快捷键快速输入数据技巧

    2022-05-14 15:29:46
  • windows10系统去除开机登录密码的解决方法

    2022-09-11 15:13:07
  • Win10如何更改系统界面的字体大小?

    2023-01-09 05:43:39
  • 在WPS表格中怎么插入批注?批注怎么使用?

    2023-05-30 14:23:28
  • win7搜索功能不见了怎么办?win7搜索功能消失不见的原因分析及两种解决方法

    2022-02-05 23:35:10
  • 怎么才能让CPU性能全开?Win10设置CPU性能全开方法

    2022-04-13 06:15:07
  • word文档编程排版的方法教程步骤

    2022-12-09 06:32:12
  • iqoo中怎么将联系人删掉?iqoo中将联系人删掉的方法

    2023-02-22 20:23:20
  • wps如何更改语言设置?wps切换语言输入法的方法

    2022-04-17 23:16:08
  • excel 如何利用自定义格式快速输入数据 体会飞一般的Excel输入技巧

    2023-05-25 19:03:46
  • Win10系统日历怎么设置?Win10设置日历教程

    2023-05-12 06:35:09
  • focusky新手制作教程

    2023-10-13 17:01:06
  • Win10专业版别人的共享文件怎么查看?

    2023-11-13 23:58:51
  • asp之家 电脑教程 m.aspxhome.com