[已解决]请大师帮忙编个程序

QCLi · 发表于 2016-5-16 17:46

本帖最后由 QCLi 于 2016-6-7 19:19 编辑

如何对超标数值自动插入三角符号?请大神帮忙！

最佳答案

月排行榜 / 总排行榜

hhzjxss

2016-5-17 00:05

本帖最后由 hhzjxss 于 2016-5-17 00:07 编辑

楼主好象是这个意思吧！

附件：

检验批质量验收记录表.zip (22.12 KB, 下载次数: 45)

2016-5-17 00:07 上传

点击文件名下载附件

Option Explicit
Private Sub 标示超标值_Click()
Dim i%, j%, n%, k%, m%
Dim Kmax%, Kmin%
Dim str$
Dim Pic As Shape
Dim rngtop%, rngleft%, rngwid%, rnghig%
On Error Resume Next
''删除原三角形
For Each Pic In ActiveSheet.Shapes
If Pic.Name Like "AutoShape*" Then
Pic.Delete
End If
Next
For i = 17 To 32
str = Cells(i, 6).Value
str = Replace(str, "mm", "")
n = InStr(1, str, ",")
m = InStr(1, str, "±")
If n > 0 Then
Kmax = Left(str, n - 1)
Kmin = Mid(str, n + 1, Len(str))
ElseIf n = 0 Then
If m > 0 Then
str = Replace(str, "±", "")
Kmax = str
Kmin = -str
ElseIf m = 0 Then
Kmax = Left(str, Len(str))
End If
End If
For j = 7 To 16
If Cells(i, j) <> "" Then
k = Cells(i, j).Value
If k > Kmax Or k < Kmin Then
''画三角形
rngtop = Cells(i, j).Top
rngwid = Cells(i, j).ColumnWidth
rngleft = Cells(i, j).Left + rngwid
rnghig = Cells(i, j).RowHeight / 2 - 9.75 / 2
ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, rngleft + rngwid, rngtop + rnghig, 11.25, 9.75).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Fill.Visible = msoFalse
Cells(i, j).Select
End If
End If
Next j
Next i
End Sub

复制代码

跳转到最佳答案楼层

爱疯 · 发表于 2016-5-16 20:29

看不懂题意

hhzjxss · 发表于 2016-5-16 22:24

没搞头，下载了，一打开excel就崩溃了！

hhzjxss · 发表于 2016-5-16 22:29

爱疯发表于 2016-5-16 20:29
看不懂题意

楼主的意思是这样的：

前面那一列，就是规范给定的的偏差值，对于每一行来说，当后面各列的数值大于最前面那列的数值时，就属于超标了，是不符合要求的，就给这个单元格用一个三角形标出来！

其实三角形是不发了标的，除非用VBA去画一个，建议楼主用条件格式，可以将单元格标示为红色，这样打印为黑白颜色的时候，红色也是深色的，也看得出来！

hhzjxss · 发表于 2016-5-17 00:05

这个最佳答案由 hhzjxss 给出，感谢 hhzjxss 的回答。

单击隐藏图章

本帖最后由 hhzjxss 于 2016-5-17 00:07 编辑

楼主好象是这个意思吧！

附件：

检验批质量验收记录表.zip (22.12 KB, 下载次数: 45)

2016-5-17 00:07 上传

点击文件名下载附件

Option Explicit
Private Sub 标示超标值_Click()
Dim i%, j%, n%, k%, m%
Dim Kmax%, Kmin%
Dim str$
Dim Pic As Shape
Dim rngtop%, rngleft%, rngwid%, rnghig%
On Error Resume Next
''删除原三角形
For Each Pic In ActiveSheet.Shapes
If Pic.Name Like "AutoShape*" Then
Pic.Delete
End If
Next
For i = 17 To 32
str = Cells(i, 6).Value
str = Replace(str, "mm", "")
n = InStr(1, str, ",")
m = InStr(1, str, "±")
If n > 0 Then
Kmax = Left(str, n - 1)
Kmin = Mid(str, n + 1, Len(str))
ElseIf n = 0 Then
If m > 0 Then
str = Replace(str, "±", "")
Kmax = str
Kmin = -str
ElseIf m = 0 Then
Kmax = Left(str, Len(str))
End If
End If
For j = 7 To 16
If Cells(i, j) <> "" Then
k = Cells(i, j).Value
If k > Kmax Or k < Kmin Then
''画三角形
rngtop = Cells(i, j).Top
rngwid = Cells(i, j).ColumnWidth
rngleft = Cells(i, j).Left + rngwid
rnghig = Cells(i, j).RowHeight / 2 - 9.75 / 2
ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, rngleft + rngwid, rngtop + rnghig, 11.25, 9.75).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Fill.Visible = msoFalse
Cells(i, j).Select
End If
End If
Next j
Next i
End Sub

复制代码

QCLi · 发表于 2016-5-17 09:27

楼主好象是这个意思吧！

数据变动后不能自动删除原三角形

hhzjxss · 发表于 2016-5-17 21:35

QCLi 发表于 2016-5-17 09:27
数据变动后不能自动删除原三角形

我是设置了一张表的，后面的表要另外设置行号！

hhzjxss · 发表于 2016-5-17 21:57

我重新改了一下行号，你看看是不是这个意思？

工程质量验收检验数值超标自动标示为三角形

0 个回复 - 0 次查看

昨天看到一个网友问这个问题：如何对超标数值自动插入三角符号意思是黄色单元格内（G：P列）的数值超过这一行最前面的蓝色单元格（F列）时，就在超过的数值所在的单元格标示红色的三角形。昨天晚上临时写了 ...

2016-5-17 21:56 - hhzjxss - 『Excel VBA程序开发』

QCLi · 发表于 2016-5-18 09:09

我重新改了一下行号，你看看是不是这个意思？

hhzjxss老师，我的意思是黄色单元格内（G：P列）的数值要是设置随机数的话，每次数据变动不能自动删除原三角形。

hhzjxss · 发表于 2016-5-19 20:08

QCLi 发表于 2016-5-18 09:09
hhzjxss老师，我的意思是黄色单元格内（G：P列）的数值要是设置随机数的话，每次数据变动不能自动删除原三角 ...

已经在四楼更新，请下载之！

		自动登录	找回密码
密码			注册

[已解决]请大师帮忙编个程序

相关帖子

评分