[已解决]请大师帮帮忙

QCLi

请大师帮忙编个程序：建筑工程检验批超标数值自动标示三角符号。感谢！
具体意思是：（H：Q列）单元格内的数值如果超过（G列）单元格时，就在超过的数值所在的单元格标示红色的三角形。三角形符号要随数据变动而变动（H：Q列的数值是要设随机数的）。

最佳答案

月排行榜 / 总排行榜

dsmch

2016-5-19 13:18

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, k&
   
3. For Each m In ActiveSheet.Shapes
   
4.     If m.Type <> 8 Then m.Delete
   
5. Next
   
6. For k = 17 To 91 Step 37
   
7.     arr = Cells(k, "g").Resize(16, 11)
   
8.     ReDim brr(1 To UBound(arr), 1 To 2)
   
9.     For i = 1 To UBound(arr)
   
10.         If InStr(arr(i, 1), "±") Then
    
11.             brr(i, 1) = 0 - Val(Mid(arr(i, 1), 2))
    
12.             brr(i, 2) = Val(Mid(arr(i, 1), 2))
    
13.         ElseIf InStr(arr(i, 1), ",") Then
    
14.             x = Split(arr(i, 1), ",")
    
15.             brr(i, 1) = Application.Min(Val(x(0)), Val(x(1)))
    
16.             brr(i, 2) = Application.Max(Val(x(0)), Val(x(1)))
    
17.         Else
    
18.             brr(i, 1) = 0: brr(i, 2) = Val(arr(i, 1))
    
19.         End If
    
20.     Next
    
21.     For i = 1 To UBound(arr)
    
22.         For j = 2 To UBound(arr, 2)
    
23.             If arr(i, j) = "" Then arr(i, j) = 0
    
24.             If Not (arr(i, j) >= brr(i, 1) And arr(i, j) <= brr(i, 2)) Then
    
25.                 Set rng = Cells(i + k - 1, j + 6)
    
26.                 x = rng.Left: y = rng.Top
    
27.                 h = rng.Height * 0.9: w = rng.Width * 0.9
    
28.                 ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x, y, w, h).Select
    
29.                 Selection.ShapeRange.Fill.Transparency = 0.6
    
30.                 Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    
31.             End If
    
32.         Next
    
33.     Next
    
34. Next
    
35. End Sub

复制代码

跳转到最佳答案楼层

QCW911

工程质量验收检验数值超标自动标示为三角形
http://www.excelpx.com/thread-417869-1-1.html

这个加一个计算钱清空表内三角就可以了，重新画出来

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, k&
   
3. For Each m In ActiveSheet.Shapes
   
4.     If m.Type <> 8 Then m.Delete
   
5. Next
   
6. For k = 17 To 91 Step 37
   
7.     arr = Cells(k, "g").Resize(16, 11)
   
8.     ReDim brr(1 To UBound(arr), 1 To 2)
   
9.     For i = 1 To UBound(arr)
   
10.         If InStr(arr(i, 1), "±") Then
    
11.             brr(i, 1) = 0 - Val(Mid(arr(i, 1), 2))
    
12.             brr(i, 2) = Val(Mid(arr(i, 1), 2))
    
13.         ElseIf InStr(arr(i, 1), ",") Then
    
14.             x = Split(arr(i, 1), ",")
    
15.             brr(i, 1) = Application.Min(Val(x(0)), Val(x(1)))
    
16.             brr(i, 2) = Application.Max(Val(x(0)), Val(x(1)))
    
17.         Else
    
18.             brr(i, 1) = 0: brr(i, 2) = Val(arr(i, 1))
    
19.         End If
    
20.     Next
    
21.     For i = 1 To UBound(arr)
    
22.         For j = 2 To UBound(arr, 2)
    
23.             If arr(i, j) = "" Then arr(i, j) = 0
    
24.             If Not (arr(i, j) >= brr(i, 1) And arr(i, j) <= brr(i, 2)) Then
    
25.                 Set rng = Cells(i + k - 1, j + 6)
    
26.                 x = rng.Left: y = rng.Top
    
27.                 h = rng.Height * 0.9: w = rng.Width * 0.9
    
28.                 ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, x, y, w, h).Select
    
29.                 Selection.ShapeRange.Fill.Transparency = 0.6
    
30.                 Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    
31.             End If
    
32.         Next
    
33.     Next
    
34. Next
    
35. End Sub

复制代码

dsmch

………………

hhzjxss

楼主在这里也发贴了呀，

QCLi

是的

QCLi

dsmch 发表于 2016-5-19 13:18

再请教dsmch老师一个问题：假如数据所在的列和行变了要改哪些参数？

QCLi

非常感谢

dsmch 老师

QCLi

dsmch  第6、7行代码  [color=rgb(153, 153, 153) !important]发表于 2016-5-21 19:26

dsmch 老师，为什么三角形在我的其他文件里显示很粗的线条？