Excel-VBA-质量问题可视化管理-17-删除问题

最新推荐文章于 2022-02-13 20:58:56 发布

Coding的巴扎黑

最新推荐文章于 2022-02-13 20:58:56 发布

阅读量337

点赞数

分类专栏： VBA-Excel 文章标签： vba excel 形状

本文链接：https://blog.csdn.net/zishendianxia/article/details/121657934

版权

VBA-Excel 专栏收录该内容

39 篇文章 7 订阅

订阅专栏

系统：Windows 10
软件：Excel 2016

本系列是假设一种应用场景，键盘质量检查中，发现问题，如何在键盘图片上进行标记和后续的跟踪管理。其实也同样适用在其它应用场景，尤其与位置相关的质量特性管理上
本文拟实现对新增问题对应形状的位置、颜色保存
核心知识点为用多形状表示问题

Part 1：项目功能介绍

之前介绍了基于单形状问题表征的一系列操作
接下来讲讲基于多形状的问题表征，只介绍以下核心4大功能
- 增，定义问题，采用多圆形来表征
- 删，删除一个问题
- 改，基于问题号修改问题
- 查，基于问题号查询问题

Part 2：新增问题细节优化

之前新增问题中的文字部分逻辑有点问题，优化一下
- 新增问题的序号是在之前的序号基础上+1
- 若数据库中没有任何问题，则从1开始计数

    ' 如果数据全部删除了
    If inputRow = 3 Then
        middleTxt = 1
    ' 如果已有数据，序号向后增加
    Else
        upTxt = sht.Cells(inputRow - 1, "W")
        middleTxt = CInt(upTxt) + 1
    End If

另外考虑到形状中间的数字显示问题，把形状大小和显示的文字大小，都调整了一下，其中文字大小调整，使用录制宏录制了一段代码

    widthVal = 30
    heightVal = 30
    positionX = sht.Range("B22").Left
    positionY = sht.Range("B22").Top
    
    Set newShape = sht.Shapes.AddShape(msoShapeOval, positionX, positionY, widthVal, heightVal)
    newShape.TextFrame2.TextRange.Characters.Text = middleTxt
    
    ' 文字居中
    newShape.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    newShape.TextFrame2.VerticalAnchor = msoAnchorMiddle
    newShape.TextFrame2.TextRange.Font.Size = 6

Part 3：删除问题

对J-L区域，N-W区域进行问题删除，基于拟删除的问题号，进行比对删除

请添加图片描述

动图
请添加图片描述

Part 4：代码

Sub 删除()
    Set sht = ThisWorkbook.Worksheets("问题管理")
    problemID = sht.Range("B15")
    
    ' 删除问题
    maxRow = sht.Cells(Rows.Count, "J").End(xlUp).Row
    
    For i = 3 To maxRow Step 1
        existsID = sht.Cells(i, "J")
        If existsID = problemID Then
            sht.Range("J" & i & ":L" & i).Select
            Selection.Delete Shift:=xlUp
        End If
    Next
    
    ' 删除问题对应形状信息
    maxRow = sht.Cells(Rows.Count, "N").End(xlUp).Row
    
    For i = 3 To maxRow Step 1
        existsID = sht.Cells(i, "N")
        If existsID = problemID Then
            sht.Range("N" & i & ":W" & i).Select
            Selection.Delete Shift:=xlUp
            ' 从删除的下一行数据开始
            i = i - 1
        End If
    Next
End Sub