数据提取分布连线

众望星君

连线.7z (38.57 KB, 下载次数: 9)

2024-9-12 15:31 上传

点击文件名下载附件

gwjkkkkk

。。。。。。。。。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, j&, k&, r&, c&, n&, x1#, y1#, x2#, y2#
   
    Application.ScreenUpdating = False
    ActiveSheet.Lines.Delete
   
    r = Cells(Rows.Count, "H").End(xlUp).Row
    With Range("H3:S" & r)
        r = .Rows.Count: c = .Columns.Count
        For i = 1 To r Step 16
            With .Cells(i, 1).Resize(11, c)
                Intersect(.Offset(), .Offset(1, 1)).Cells.Clear
                ar = .Value
                For k = 2 To UBound(ar)
                    n = 0
                    For j = 2 To UBound(ar, 2)
                        If ar(1, j) = ar(k, 1) Then
                             With .Cells(k, j)
                                .Value = ar(k, 1)
                                .Interior.Color = 15849925
                                n = 0
                             End With
                        Else
                            n = n + 1
                            .Cells(k, j).Value = n
                        End If
                    Next j
                Next k
                n = 0
                For j = 2 To UBound(ar, 2)
                    For k = 2 To UBound(ar)
                        With .Cells(k, j)
                            If .Interior.Color = 15849925 Then
                                If n = 1 Then
                                    x2 = .Left + .Width / 2
                                    y2 = .Top + .Height / 2
                                    ActiveSheet.Shapes.AddLine x1, y1, x2, y2
                                     With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line
                                          .DashStyle = msoLineSolid
                                          .BeginArrowheadStyle = msoArrowheadOval
                                          .EndArrowheadStyle = msoArrowheadOpen
                                          .Weight = 1
                                          .ForeColor.ObjectThemeColor = msoThemeColorAccent6
                                    End With
                                    x1 = x2: y1 = y2
                                Else
                                    x1 = .Left + .Width / 2
                                    y1 = .Top + .Height / 2
                                    n = 1
                                End If
                            End If
                        End With
                    Next k
                Next j
            End With
        Next i
    End With
   
    Application.ScreenUpdating = True
End Sub

众望星君

gwjkkkkk 发表于 2024-9-13 20:37
Option Explicit
Sub test()
    Dim ar, i&, j&, k&, r&, c&, n&, x1#, y1#, x2#, y2#

老大 连线的线条，如果可以把连线数值的升序与降序，用两种颜色区分，那就完美了，比如：2连5用红色线条，5连2的话，就用绿色线条

gwjkkkkk

众望星君 发表于 2024-9-14 09:03
老大 连线的线条，如果可以把连线数值的升序与降序，用两种颜色区分，那就完美了，比如：2连5用红色线条 ...

平行怎么办？？？

众望星君

gwjkkkkk 发表于 2024-9-15 13:49
平行怎么办？？？

平行用黑色

gwjkkkkk

众望星君 发表于 2024-9-15 13:53
平行用黑色

简单修改一下即可。。。