Excel-VBA-质量问题可视化管理-11-超期问题显示

系统：Windows 10
软件：Excel 2016

• 本系列是假设一种应用场景，键盘质量检查中，发现问题，如何在键盘图片上进行标记和后续的跟踪管理
• 其实也同样适用在其它应用场景，尤其与位置相关的质量特性管理上
• 核心知识点：在背景图片特定位置插入一个圆圈（表示问题点），并对圆圈进行进行颜色等特性的改变

Part 1： 项目功能介绍（更新）

1. 在写的过程中，发现需要修正一下上次的功能，功能模块如下
2. 录入问题（OK）
   • 录入尺寸问题，标记圆形
   • 录入颜色问题，标记矩形
   • 清空显示问题
   • 保存当前状态：新增的问题点位置和颜色都是动态变化的，需要保存最新状态
3. 删除问题（OK）
   • 基于问题唯一ID号删除某问题
4. 查询问题，基于以下条件条件逻辑与进行查询，若无选择条件，默认显示所有问题（OK）
   • 基于问题状态：已解决，未解决
   • 问题种类：尺寸，颜色
   • 问题ID号，只显示特定ID号问题
   • 时间节点：超期，未超期
   • 选中图片上问题获取其对应的问题信息
5. 问题修改（OK）
   • 修改问题状态，更新其颜色表示，未解决-红色；已解决-绿色
6. 考虑到操作的便利性，对于录入问题部分，设置快捷键（OK）

操作界面（仅做示意，并不表示真有质量问题；如有侵权请联系我）

Part 2： 拟实现功能描述

1. 本次拟实现识别未解决问题中超期问题的显示和数目统计

过程动图

静图

Part 3： 代码逻辑

1. 清除原有图形
2. 新增两个变量，用来存储未解决问题中的尺寸问题、颜色问题数目，并初始化为0
3. 获取当前日期
4. 对数据库区域进行循环，多层判断
   • 判断问题是否已解决
   • 对未解决的问题，判断有无时间节点，这里没有时间节点暂不考虑
   • 有时间节点的，与当前日期比对，小于当前日期的，为超期问题
   • 画图

Part 4：代码

超期问题获取

Sub exceedTime()
    Call delAllShape
    
    sizeProblem = 0
    colorProblem = 0
    
    currentDate = Date
    Set sht = ThisWorkbook.Worksheets("问题管理")
    ' 获取行数
    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row
    
    For i = 3 To maxRow Step 1
        problemStatus = sht.Cells(i, "L").Value
        
        If problemStatus = "未解决" Then
            solveDate = sht.Cells(i, "P").Value
            If solveDate <> "" Then
                solveDate = CDate(solveDate)
                If solveDate < currentDate Then
                    shapeName = sht.Cells(i, "Q").Value
                    problemType = sht.Cells(i, "K").Value
                    
                    If problemType = "尺寸" Then
                        shapeType = msoShapeOval
                        sizeProblem = sizeProblem + 1
                    Else
                        shapeType = msoShapeRectangle
                        colorProblem = colorProblem + 1
                    End If
                    positionX = sht.Cells(i, "R").Value
                    positionY = sht.Cells(i, "S").Value
                    widthVal = sht.Cells(i, "T").Value
                    heightVal = sht.Cells(i, "U").Value
                    fillColor = sht.Cells(i, "V").Value
                    lineColor = sht.Cells(i, "W").Value
                    
                    shapeName = drawShape(sht, shapeType, positionX, positionY, widthVal, heightVal, fillColor, lineColor)
                    sht.Cells(i, "Q").Value = shapeName
                End If
            End If
        End If
    Next i
    
    sht.Range("H18") = sizeProblem
    sht.Range("H19") = colorProblem

End Sub

画图

Function drawShape(sht, shapeType, positionX, positionY, widthVal, heightVal, fillColor, lineColor)
    Set newShape = sht.Shapes.AddShape(shapeType, positionX, positionY, widthVal, heightVal)
    shapeName = newShape.Name
    Debug.Print (shapeName)

    With newShape.Fill
        .Visible = msoTrue
        .ForeColor.RGB = fillColor
        .Transparency = 0
        .Solid
    End With

    With newShape.Line
        .Visible = msoTrue
        .ForeColor.RGB = lineColor
        .Transparency = 0
    End With
    
    drawShape = shapeName
End Function

代码截图
超期问题获取

画图

Part 5：部分代码解读

1. currentDate = Date获取当前日期，为时间格式
2. solveDate = CDate(solveDate)将字符串格式转换为日期格式，可能存在风险，如果两边日期的写法不同，如日和月的位置不同，在对比大小时，不知道是否可以识别出来。读者可以试一试

---

• 更多学习交流，可加小编微信号learningBin

---

更多精彩，请关注微信公众号
扫描二维码，关注本公众号