各位老师，请教下如何实现数据汇总并查看

Benfyhu

各位老师，请教下如何实现数据汇总并查看。谢谢

quqiyuan

参与一下，仅供参考。。。。

quqiyuan

代码如下，，，
Sub test()  '增加数据
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("油墨调配录入")
    Set sh = wb.Sheets("油墨调配使用数据库")
    r = sht.[a17].End(3).Row
    rr = sh.[a1048576].End(3).Row
    If rr > 2 Then xuhao = sh.Cells(rr, 1).Value Else rr = 3: xuhao = 0
    arr = sht.Range(sht.[A3], sht.Cells(r, "o"))
    s = Split("b3 f3 m3 o3 b4 f4 i4 l4 n4")
    Set Rng = sht.[a8:k16,m8:o16]
    ReDim brr(0, 8)
    ReDim crr(1 To r - 7, 1 To 11)
    ReDim drr(1 To r - 7, 0)
    For i = 0 To UBound(brr, 2)
        brr(0, i) = sht.Range(s(i))
    Next
    For i = 6 To UBound(arr)
        n = n + 1
        For j = 1 To UBound(crr, 2)
            If j <= 6 Then crr(n, j) = arr(i, j)
            If j = 7 Then crr(n, j) = arr(i, 9)
            If j = 8 Then crr(n, j) = arr(i, 11)
            If j > 8 Then crr(n, j) = arr(i, 3 + j)
            drr(n, 0) = xuhao + n
        Next
    Next
    With sh
        .Cells(rr + 1, 1).Resize(n) = drr
        .Cells(rr + 1, 2).Resize(n, 9) = brr
        .Cells(rr + 1, 11).Resize(n, 11) = crr
    End With
    For i = 0 To UBound(s)
        sht.Range(s(i)) = Empty
    Next
    Rng.Value = Empty
    Beep
End Sub


Sub test1() '查询
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("油墨调配录入")
    Set sh = wb.Sheets("油墨调配使用数据库")
    rr = sh.[a1048576].End(3).Row
    arr = sh.[a1].CurrentRegion
    Set Rng = sht.[a8:k16,m8:o16]
    ReDim brr(1 To 1000, 1 To 2)
    ReDim crr(1 To 1000, 1 To 11)
    s = sht.[b3] & sht.[o3]
    For i = 4 To UBound(arr)
        ss = arr(i, 2) & arr(i, 5)
        If ss = s Then
        n = n + 1
        For j = 1 To 10
            If j <= 6 Then crr(n, j) = arr(i, j + 10)
            If j = 7 Then crr(n, 9) = arr(i, 17)
            If j = 8 Then crr(n, 11) = arr(i, 18)
            If j > 8 Then brr(n, j - 8) = arr(i, j + 11)
        Next
        End If
    Next
    Rng.Value = Empty
    With sht
        .Cells(8, 1).Resize(n, 11) = crr
        .Cells(8, 13).Resize(n, 2) = brr
    End With
    Beep
End Sub

蓝桥玄霜

提交的例子：

Benfyhu

quqiyuan 发表于 2024-11-24 14:59
代码如下，，，
Sub test()  '增加数据
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet

非常感 谢quqiyuan老师，还有些小问题。看下是怎么优化一下

quqiyuan

Benfyhu 发表于 2024-11-24 15:46
非常感 谢quqiyuan老师，还有些小问题。看下是怎么优化一下

我这边测试增加数据到数据库是没有问题，你用我的附件试一下，以前那几个你改回来，我测试时候没有注意是合并的2/3行，造成那合并的改了没有改过来
查询那里那些数据没有填，因为你查询只是两个关键字，你有些数据不一致的话（例如这两个关键字相同但是日期不同），这个怎么处理

Benfyhu

quqiyuan 发表于 2024-11-24 15:58
我这边测试增加数据到数据库是没有问题，你用我的附件试一下，以前那几个你改回来，我测试时候没有注意是 ...

好的。谢谢！重新下载测试 如果是最后一行有数值，提交就是只能提交一行过去，没有这行就能全部提交了。查询那里 只要符合单号和部件两个就可以。其它不用考虑，因为日期是一样，单号和部件是唯一识别的条件

quqiyuan

从新整理了一下，你测试一下。。。

quqiyuan

代码如下。。。。
Sub test()                                                 '增加数据
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("油墨调配录入")
    Set sh = wb.Sheets("油墨调配使用数据库")
    r = sht.[a17].End(3).Row
    rr = sh.[a1048576].End(3).Row
    If rr > 2 Then xuhao = sh.Cells(rr, 1).Value Else rr = 3: xuhao = 0
    arr = sht.[a3:o16]
    s = Split("b3 f3 m3 o3 b4 f4 i4 l4 n4")
    Set Rng = sht.[a8:k16,m8:o16]
    ReDim brr(0, 8)
    ReDim crr(1 To 9, 1 To 11)
    ReDim drr(1 To 9, 0)
    For i = 0 To UBound(brr, 2)
        brr(0, i) = sht.Range(s(i))
    Next
    For i = 6 To UBound(arr)
        If arr(i, 1) <> Empty Then
            n = n + 1
            For j = 1 To UBound(crr, 2)
                If j <= 6 Then crr(n, j) = arr(i, j)
                If j = 7 Then crr(n, j) = arr(i, 9)
                If j = 8 Then crr(n, j) = arr(i, 11)
                If j > 8 Then crr(n, j) = arr(i, 3 + j)
                drr(n, 0) = xuhao + n
            Next
        End If
    Next
    With sh
        .Cells(rr + 1, 1).Resize(n) = drr
        .Cells(rr + 1, 2).Resize(n, 9) = brr
        .Cells(rr + 1, 11).Resize(n, 11) = crr
    End With
    For i = 0 To UBound(s)
        sht.Range(s(i)) = Empty
    Next
    Rng.Value = Empty
    Beep
End Sub
   
   
Sub test1()                                                '查询
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("油墨调配录入")
    Set sh = wb.Sheets("油墨调配使用数据库")
    rr = sh.[a1048576].End(3).Row
    arr = sh.[a1].CurrentRegion
    Set Rng = sht.[a8:k16,m8:o16]
    ReDim brr(1 To 1000, 1 To 2)
    ReDim crr(1 To 1000, 1 To 11)
    ReDim drr(0, 8)
    s = sht.[b3] & sht.[o3]
    For i = 4 To UBound(arr)
        ss = arr(i, 2) & arr(i, 5)
        If ss = s Then
            n = n + 1
            For j = 0 To 8
                drr(0, j) = arr(i, j + 2)
            Next
            For j = 1 To 10
                If j <= 6 Then crr(n, j) = arr(i, j + 10)
                If j = 7 Then crr(n, 9) = arr(i, 17)
                If j = 8 Then crr(n, 11) = arr(i, 18)
                If j > 8 Then brr(n, j - 8) = arr(i, j + 11)
            Next
        End If
    Next
    Rng.Value = Empty
    With sht
        .Cells(8, 1).Resize(n, 11) = crr
        .Cells(8, 13).Resize(n, 2) = brr
    End With
    s = Split("b3 f3 m3 o3 b4 f4 i4 l4 n4")
    For i = 0 To UBound(drr, 2)
        sht.Range(s(i)) = drr(0, i)
    Next
    Beep
End Sub
   

Benfyhu

quqiyuan 发表于 2024-11-24 16:33
从新整理了一下，你测试一下。。。

太感谢了，完美解决我的问题。祝您一切顺利