[已解决]信息表保存为图片，未填写提交时进行提醒

zhangjian0622

1表格信息随编号的变化，信息也开始变，自动将没个信息表保存为图片，图片以名字加身份证号码命名； 2未填写提交时进行提醒，那个未填，或者单元格变颜色.

最佳答案

月排行榜 / 总排行榜

psxk3535028-1

2021-8-31 12:55

在表格文件夹下面创建  名为“图片” 文件夹，

Sub 提交1()
Application.ScreenUpdating = False
Dim n%, m%, x%, y%, k%
On Error GoTo 100
    If Sheets("数据库").[A:A].Find([j3]) = [j3] Then
        MsgBox "此单已经保存过了！"
    Else
100:
        rr = Array([c4], [j4], [c5], [j5], [c6], [j6], [b7], [d7], [f7], [h7], [j7], [b8], [d8], [f8], [h8], [j8], [b10], [f10], [b11])
        ss = Array([b4], [i4], [b5], [i5], [b6], [i6], [a7], [c7], [e7], [g7], [i7], [a8], [c8], [e8], [g8], [i8], [a10], [e10], [a11])
        For i = 0 To UBound(rr)
            If Trim(rr(i)) = "" Then
                If a = "" Then
                   a = ss(i) & "：" & Replace(rr(i).Address, "$", "")
                    Range(Replace(rr(i).Address, "$", "")).Interior.Color = RGB(255, 153, 204)
                Else
                    a = a & Chr(10) & ss(i) & "：" & Replace(rr(i).Address, "$", "")
                    Range(Replace(rr(i).Address, "$", "")).Interior.Color = RGB(255, 153, 204)
                End If
            End If
        Next i
        If a <> "" Then
            MsgBox "以下单元格为空：" & Chr(10) & " " & Chr(10) & a & Chr(10) & " " & Chr(10) & "不能提交" & Chr(10) & Chr(10) & "请修改后再提交"
            Exit Sub
        End If
        
        m = Sheets("数据库").[A65536].End(xlUp).Row + 1
        With Sheets("数据库")
            .Cells(m, "A").Value = [j3] '编号
            .Cells(m, "B").Value = [j4] '开单日期
            .Cells(m, "C").Value = [c4] '客户
            .Cells(m, "D").Value = [c5] '品名
            .Cells(m, "E").Value = [c6] '料号
            .Cells(m, "F").Value = [j6] '成品规格
            .Cells(m, "G").Value = [j5] '生产数量
            .Cells(m, "H").Value = [b9] '封样单号
            .Cells(m, "I").Value = [E9] '刀模编号
            .Cells(m, "J").Value = [i10] '拼版数量
            .Cells(m, "K").Value = [b7] '材料1
            .Cells(m, "L").Value = [h7] '规格1
            .Cells(m, "M").Value = [f7] '供应商1
            .Cells(m, "N").Value = [j7] '材料数量
            .Cells(m, "O").Value = [b8] '材料2
            .Cells(m, "P").Value = [h8] '规格2
            .Cells(m, "Q").Value = [f8] '供应商2
            .Cells(m, "R").Value = [j8] '材料数量2
            .Cells(m, "S").Value = [H9] '加工车次
            .Cells(m, "T").Value = [b10] '包装方式
            .Cells(m, "U") = [f10] '包装数量
            .Cells(m, "V").Value = [J9] '交期
            .Cells(m, "W").Value = [b11] '物流方式
        End With
        MsgBox "提交成功！"
    End If
   
Range("c4, j4, c5, j5, c6, j6, b7, d7, f7, h7, j7, b8, d8, f8, h8, j8, b10, f10, b11").Interior.Pattern = xlNone    '单元格背景--无颜色

Range("A2:K11").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ActiveSheet.Paste
     Set Newshape = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
     With ActiveSheet.ChartObjects.Add(1, 1, 1, 1)
         .Width = Newshape.Width
         .Height = Newshape.Height
          Newshape.Copy
         .Select
         .Chart.Paste
         .Chart.Export ActiveWorkbook.Path & "\图片\" & Cells(4, 3) & " " & Cells(5, 3) & ".JPG"
         .Delete
     End With
     Newshape.Delete
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

zhangjian0622

A4-K11其中的内容是必填的。

psxk3535028-1

在表格文件夹下面创建  名为“图片” 文件夹，

Sub 提交1()
Application.ScreenUpdating = False
Dim n%, m%, x%, y%, k%
On Error GoTo 100
    If Sheets("数据库").[A:A].Find([j3]) = [j3] Then
        MsgBox "此单已经保存过了！"
    Else
100:
        rr = Array([c4], [j4], [c5], [j5], [c6], [j6], [b7], [d7], [f7], [h7], [j7], [b8], [d8], [f8], [h8], [j8], [b10], [f10], [b11])
        ss = Array([b4], [i4], [b5], [i5], [b6], [i6], [a7], [c7], [e7], [g7], [i7], [a8], [c8], [e8], [g8], [i8], [a10], [e10], [a11])
        For i = 0 To UBound(rr)
            If Trim(rr(i)) = "" Then
                If a = "" Then
                   a = ss(i) & "：" & Replace(rr(i).Address, "$", "")
                    Range(Replace(rr(i).Address, "$", "")).Interior.Color = RGB(255, 153, 204)
                Else
                    a = a & Chr(10) & ss(i) & "：" & Replace(rr(i).Address, "$", "")
                    Range(Replace(rr(i).Address, "$", "")).Interior.Color = RGB(255, 153, 204)
                End If
            End If
        Next i
        If a <> "" Then
            MsgBox "以下单元格为空：" & Chr(10) & " " & Chr(10) & a & Chr(10) & " " & Chr(10) & "不能提交" & Chr(10) & Chr(10) & "请修改后再提交"
            Exit Sub
        End If
        
        m = Sheets("数据库").[A65536].End(xlUp).Row + 1
        With Sheets("数据库")
            .Cells(m, "A").Value = [j3] '编号
            .Cells(m, "B").Value = [j4] '开单日期
            .Cells(m, "C").Value = [c4] '客户
            .Cells(m, "D").Value = [c5] '品名
            .Cells(m, "E").Value = [c6] '料号
            .Cells(m, "F").Value = [j6] '成品规格
            .Cells(m, "G").Value = [j5] '生产数量
            .Cells(m, "H").Value = [b9] '封样单号
            .Cells(m, "I").Value = [E9] '刀模编号
            .Cells(m, "J").Value = [i10] '拼版数量
            .Cells(m, "K").Value = [b7] '材料1
            .Cells(m, "L").Value = [h7] '规格1
            .Cells(m, "M").Value = [f7] '供应商1
            .Cells(m, "N").Value = [j7] '材料数量
            .Cells(m, "O").Value = [b8] '材料2
            .Cells(m, "P").Value = [h8] '规格2
            .Cells(m, "Q").Value = [f8] '供应商2
            .Cells(m, "R").Value = [j8] '材料数量2
            .Cells(m, "S").Value = [H9] '加工车次
            .Cells(m, "T").Value = [b10] '包装方式
            .Cells(m, "U") = [f10] '包装数量
            .Cells(m, "V").Value = [J9] '交期
            .Cells(m, "W").Value = [b11] '物流方式
        End With
        MsgBox "提交成功！"
    End If
   
Range("c4, j4, c5, j5, c6, j6, b7, d7, f7, h7, j7, b8, d8, f8, h8, j8, b10, f10, b11").Interior.Pattern = xlNone    '单元格背景--无颜色

Range("A2:K11").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ActiveSheet.Paste
     Set Newshape = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
     With ActiveSheet.ChartObjects.Add(1, 1, 1, 1)
         .Width = Newshape.Width
         .Height = Newshape.Height
          Newshape.Copy
         .Select
         .Chart.Paste
         .Chart.Export ActiveWorkbook.Path & "\图片\" & Cells(4, 3) & " " & Cells(5, 3) & ".JPG"
         .Delete
     End With
     Newshape.Delete
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub