http://www.pptjcw.com

wps页眉页脚怎么设置:excel矩阵数据怎么绘制线条

    excel矩阵数据怎么绘制线条

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

    wps页眉页脚怎么设置: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

    提示:如果您觉得本文不错,请点击分享给您的好友!谢谢

    上一篇:wps如何自动生成目录:excel公式怎么找到和的加数 下一篇:wps演示者视图:怎么用word翻译功能翻译外语文本?

    郑重声明:本文版权归原作者所有,转载文章仅为传播更多信息之目的,如作者信息标记有误,请第一时间联系我们修改或删除,多谢。