有三个问题需要请教各位老师，具体请请附件

Benfyhu

laterite

第一个问题：

    Dim s
    For s = 2 To Sheets("纸张类-来料检报告数据库").Cells(Rows.Count, 3).End(xlUp).Row
        If Sheets("纸张类-来料检验").Cells(4, 2) = Sheets("纸张类-来料检报告数据库").Range("c" & s) Then
            MsgBox "采购单号已存在！", vbCritical, "错误！"
            Exit Sub
        End If
    Next s

清风竹-

第二个问，数据提取。重写了代码。

Sub 调取纸张类来料检验报告数据()
    Dim i, x, m, j, n
   m = Sheets("纸张类-来料检报告数据库").Cells(Rows.Count, 2).End(3).Row
   
    If m < 4 Then
       MsgBox "     《纸张类-来料检报告数据库》无数据。"
       Exit Sub
    Else
       arr = Sheets("纸张类-来料检报告数据库").Range("a4:dh" & m)
    End If
   
     brr = [{"B4","D4","B5","B6","B7","D6","D6","G4","D8","G8","B8"}]
       brr2 = [{"c34","c35","g35","n35","B36","D36","g36","m36"}]
     ReDim crr(1 To 22, 1 To 7)
  
  dh = Sheets("纸张类-来料检验").Cells(4, 2)
  wllx = Sheets("纸张类-来料检验").Cells(7, 4)
   If dh = "" Then
    MsgBox "     (⊙o⊙)您好-这么懒，单号都不写。请完善后再提交。"
     Exit Sub
  End If
  
  If wllx = "" Then
    MsgBox "     (⊙o⊙)您好-“物料类型” 未填写。请完善后再提交。"
     Exit Sub
  End If
  
    For i = 1 To UBound(arr)
        If dh & wllx = arr(i, 3) & arr(i, 8) Then
            x = i
            Exit For
        End If
    Next
    If x = 0 Then MsgBox "     (⊙o⊙)您好 - 无调取数据。": Exit Sub
   
    For j = 1 To UBound(brr)
        Range(brr(j)) = arr(x, j + 2)
    Next
     For j = 1 To UBound(brr2)
        Range(brr2(j)) = arr(x, j + 104)
    Next
   
    For j = 17 To 104 Step 4
        n = n + 1
        crr(n, 1) = arr(x, j)
        crr(n, 2) = arr(x, j + 1)
        crr(n, 3) = arr(x, j + 2)
        crr(n, 7) = arr(x, j + 3)
    Next
    Range("g12").Resize(n, 7) = crr

MsgBox "     (⊙o⊙)您好-数据调取成功"
            
   
End Sub

Benfyhu

laterite 发表于 2023-3-28 20:13
第一个问题：

    Dim s

您好。可能理解错了。我想的是如图。。只要是这部份全部是一样的就不能重复提交。但凡有一项不一样都可以提交的意思

Benfyhu

清风竹- 发表于 2023-3-29 10:58
第二个问，数据提取。重写了代码。

Sub 调取纸张类来料检验报告数据()

谢谢！！提交数据能帮忙优化下吗？总感觉是不是这个原因，所以运行比较慢

清风竹-

Benfyhu 发表于 2023-3-29 18:53
谢谢！！提交数据能帮忙优化下吗？总感觉是不是这个原因，所以运行比较慢

Sub 提交纸张类来料检验报告并清空数据()
    Dim i, x, m, j, n
    m = Sheets("纸张类-来料检报告数据库").Cells(Rows.Count, 2).End(3).Row
     If m = 2 Then m = 3
     ReDim arr(1 To 1, 1 To 112)
     crr = Range("g12").Resize(22, 7)
     brr = [{"m3","B4","D4","B5","B6","B7","D6","D6","G4","D8","G8","B8","g5","g6","g7"}]
     brr2 = [{"c34","c35","g35","n35","B36","D36","g36","m36"}]
     dh = Sheets("纸张类-来料检验").Cells(4, 2)
   If dh = "" Then
       MsgBox "     (⊙o⊙)您好-这么懒，单号都不写。请完善后再提交。"
       Exit Sub
   End If
   
     dh2 = Sheets("纸张类-来料检报告数据库").Cells(Rows.Count, 3).End(3)
   If dh = dh2 Then
      MsgBox "     (⊙o⊙)本单号已保存。不得再次提交。"
     Exit Sub
   End If
    arr(1, 1) = m - 2
    For j = 1 To UBound(brr)
        arr(1, j + 1) = Range(brr(j))
    Next
     For j = 1 To UBound(brr2)
       arr(1, j + 104) = Range(brr2(j))
    Next
   
    For j = 17 To 104 Step 4
        n = n + 1
         arr(1, j) = crr(n, 1)
         arr(1, j + 1) = crr(n, 2)
         arr(1, j + 2) = crr(n, 3)
         arr(1, j + 3) = crr(n, 7)
    Next

  Sheets("纸张类-来料检报告数据库").Cells(m + 1, 1).Resize(1, 112) = arr
          Range("B4,D4,G4,B5,B6,D6,B7,B8,D8,G8,G12:I33,M12:M33,C34,C35,G35,N35,B36,D36,G36,M36").Select
         Selection.ClearContents
             Range("B4").Select
      MsgBox "     (⊙o⊙)您好-提交成功，清空完毕"
            
   
End Sub

Benfyhu

清风竹- 发表于 2023-3-30 07:57
Benfyhu 发表于 2023-3-29 18:53
谢谢！！提交数据能帮忙优化下吗？总感觉是不是这个原因，所以运行比较慢 ...

谢谢！还有一个小问题。就是当“采购单号”  和“物料类型”，同时相同时不能提交数据。如果只是一个条件相同，都可以提交数据。。因为物料同一个单号可以有几种 不同的物料

清风竹-

Benfyhu 发表于 2023-3-30 15:00
谢谢！还有一个小问题。就是当“采购单号”  和“物料类型”，同时相同时不能提交数据。如果只是一个条件 ...

参考图片。

Benfyhu

清风竹- 发表于 2023-3-30 16:31
参考图片。

还有一个问题存在点BUG。就是条件只判断了上一行的数据相同不能提交。如果是隔行了或是隔几行就判定不出来了同样提交上去了。想要的是整个数据库里相同的这两个条件不能提交。

清风竹-

Benfyhu 发表于 2023-3-30 18:44
还有一个问题存在点BUG。就是条件只判断了上一行的数据相同不能提交。如果是隔行了或是隔几行就判定不出 ...

Sub 提交纸张类来料检验报告并清空数据()
    Dim i, x, m, j, n
    m = Sheets("纸张类-来料检报告数据库").Cells(Rows.Count, 2).End(3).Row
     If m = 2 Then m = 3
     If m < 4 Then                                              ''''''''''''''''@@@@@@@@@@@@
        arr2 = Sheets("纸张类-来料检报告数据库").Range("c4:h4") ''''''''''''''''@@@@@@@@@@@@
     Else                                                         ''''''''''''''''@@@@@@@@@@@@
        arr2 = Sheets("纸张类-来料检报告数据库").Range("c4:h" & m) ''''''''''''''''@@@@@@@@@@@@
     End If                                                         ''''''''''''''''@@@@@@@@@@@@
     
     ReDim arr(1 To 1, 1 To 112)
     crr = Range("g12").Resize(22, 7)
     brr = [{"m3","B4","D4","B5","B6","B7","D6","D6","G4","D8","G8","B8","g5","g6","g7"}]
     brr2 = [{"c34","c35","g35","n35","B36","D36","g36","m36"}]
      dh = Sheets("纸张类-来料检验").Cells(4, 2)
      wllx = Sheets("纸张类-来料检验").Cells(7, "d") ''''''''''''''''@@@@@@@@@@@@
   If dh = "" Then
       MsgBox "     (⊙o⊙)您好-这么懒，单号都不写。请完善后再提交。"
       Exit Sub
   End If
   If wllx = "" Then
       MsgBox "     (⊙o⊙)您好-这么懒，“物料类型”都不写。请完善后再提交。"
       Exit Sub
   End If
    For i = 1 To UBound(arr2)                             ''''''''''''''''@@@@@@@@@@@@
      If arr2(i, 1) & arr2(i, 6) = dh & wllx Then            ''''''''''''''''@@@@@@@@@@@@
          MsgBox "     (⊙o⊙)本单号已保存。不得再次提交。" ''''''''''''''''@@@@@@@@@@@@
         Exit Sub                                     ''''''''''''''''@@@@@@@@@@@@
      End If                                            ''''''''''''''''@@@@@@@@@@@@
    Next                                                ''''''''''''''''@@@@@@@@@@@@
   

    arr(1, 1) = m - 2
    For j = 1 To UBound(brr)
        arr(1, j + 1) = Range(brr(j))
    Next
     For j = 1 To UBound(brr2)
       arr(1, j + 104) = Range(brr2(j))
    Next
   
    For j = 17 To 104 Step 4
        n = n + 1
         arr(1, j) = crr(n, 1)
         arr(1, j + 1) = crr(n, 2)
         arr(1, j + 2) = crr(n, 3)
         arr(1, j + 3) = crr(n, 7)
    Next

  Sheets("纸张类-来料检报告数据库").Cells(m + 1, 1).Resize(1, 112) = arr
          Range("B4,D4,G4,B5,B6,D6,B7,B8,D8,G8,G12:I33,M12:M33,C34,C35,G35,N35,B36,D36,G36,M36").Select
         Selection.ClearContents
             Range("B4").Select
      MsgBox "     (⊙o⊙)您好-提交成功，清空完毕"
            
   
End Sub