数据汇总

edwin11891

按照模板全部填充了公式，但是修改了D3:L3的项目名称（因为与实际有出入），黄色与浅红色均为公式，绿色为输入条件（可不输入）。不知道理解的几个合格率对不对。

淘气的萝卜

quqiyuan 发表于 2024-12-4 22:58
代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet

非常感谢大佬的回复，虽然看不懂，但程序非常的好用
另外，表头A2与A3会移到汇总数据的最下面，帮忙再调整下，感谢！

quqiyuan

淘气的萝卜 发表于 2024-12-5 11:23
非常感谢大佬的回复，虽然看不懂，但程序非常的好用
另外，表头A2与A3会移到汇总数据的最下面，帮忙再调 ...

我运行没问题哦，估计你是不是把你说的最后那两行去掉了？我这里有个判断最后一行位置，然后减5，所以造成这个问题。要不你保留最后两行，它不够空间会插入空行的。刚刚也修正了一下一个问题。。。

quqiyuan

代码如下。。。
如果你后面没有你说的那两行，这个直接在A4输入数据就可以了
看你的选择啦
Sub test()
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("来料检验明细表")
    Set sh = wb.Sheets("查询表")
    r = sh.Cells(Rows.Count, 1).End(3).Row - 5
    xm = sh.[d1]: d = sh.[f1]
    s = xm & "|" & d
    arr = sht.[a1].CurrentRegion
    ReDim brr(1 To 10000, 1 To 100)
    Set d = CreateObject("scripting.dictionary")
'    n = 0: m = 3
'    brr(1, 1) = "供应商名称": brr(1, 2) = "交付总数": brr(1, 3) = "不合格数"
    biaoti = sh.[a3:o3]
    For i = 4 To 12
        d(biaoti(1, i)) = i
    Next
    For i = 2 To UBound(arr)
        ss = arr(i, 3) & "|" & Month(arr(i, 7))
        If InStr(ss, s) Then
            hang = hang + 1
            zong = zong + arr(i, 6)
            If Not d.exists(arr(i, 13)) Then
                n = n + 1
                d(arr(i, 13)) = n
                brr(n, 1) = arr(i, 13)
            End If
            If arr(i, 11) <> Empty Then
                If d.exists(arr(i, 11)) Then
'                    m = m + 1
'                    d(arr(i, 11)) = m
'                    brr(1, m) = arr(i, 11)
                    y = d(arr(i, 11))
                End If
            End If
            x = d(arr(i, 13))
'            y = d(arr(i, 11))
            brr(x, 100) = brr(x, 100) + 1
            brr(x, 2) = brr(x, 2) + arr(i, 6)
            brr(x, 3) = brr(x, 3) + arr(i, 9)
            If y <> Empty Then brr(x, y) = brr(x, y) + arr(i, 9): y = Empty: brr(x, 99) = brr(x, 99) + 1
        End If
    Next
    For i = 1 To n
         brr(i, 13) = Format(1 - brr(i, 3) / brr(i, 2), "0.00%")
         brr(i, 14) = Format(1 - brr(i, 99) / brr(i, 100), "0.00%")
         brr(i, 15) = "=VLOOKUP(" & brr(i, 13) & ",{0,""E级"";0.8,""D级"";0.85,""C级"";0.9,""B级"";0.95,""A级""},2)"
    Next
    If n <= r Then
        sh.[a4].Resize(r, UBound(biaoti, 2)) = ""
        sh.[a4].Resize(n, UBound(biaoti, 2)) = brr
    Else
        sh.Cells(r + 4, 1).Resize(n - r, UBound(biaoti, 2)).Insert xlShiftDown
        sh.[a4].Resize(r, UBound(biaoti, 2)) = ""
        sh.[a4].Resize(n, UBound(biaoti, 2)) = brr
    End If
    sh.[h1] = hang: sh.[j1] = zong
    Set d = Nothing
    Beep
End Sub

淘气的萝卜

quqiyuan 发表于 2024-12-5 12:18
代码如下。。。
如果你后面没有你说的那两行，这个直接在A4输入数据就可以了
看你的选择啦

完美！！！烦请大佬再帮忙完善下查询表中第二行数据统计

哄哄771

~~~~~~改   ~~~~

淘气的萝卜

哄哄771 发表于 2024-12-5 14:24
~~~~~~改   ~~~~

感谢回复~~~~
公式很好用，就是打开有点慢，另外，没有数据的行不要显示出来，能优化吗？能用VBA就更好了

quqiyuan

淘气的萝卜 发表于 2024-12-5 13:37
完美！！！烦请大佬再帮忙完善下查询表中第二行数据统计

增加你这些需求，你测试一下咯，有可能对要求理解有偏差。仅供参考。。。

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 = sh.Cells(Rows.Count, 1).End(3).Row - 5
    xm = sh.[d1]: d = sh.[f1]
    s = xm & "|" & d
    arr = sht.[a1].CurrentRegion
    ReDim brr(1 To 10000, 1 To 100)
    Set d = CreateObject("scripting.dictionary")
'    n = 0: m = 3
'    brr(1, 1) = "供应商名称": brr(1, 2) = "交付总数": brr(1, 3) = "不合格数"
    biaoti = sh.[a3:o3]
    For i = 4 To 12
        d(biaoti(1, i)) = i
    Next
    For i = 2 To UBound(arr)
        ss = arr(i, 3) & "|" & Month(arr(i, 7))
        If InStr(ss, s) Then
            hang = hang + 1
            zong = zong + arr(i, 6)
            buliang = buliang + arr(i, 9)
            If arr(i, 10) = "机加" Then
                jijia = jijia + arr(i, 6)
                jijia_buliang = jijia_buliang + arr(i, 9)
            ElseIf arr(i, 10) = "大板" Then
                daban = daban + arr(i, 6)
                daban_buliang = daban_buliang + arr(i, 9)
            ElseIf arr(i, 10) = "钣金" Then
                banjin = banjin + arr(i, 6)
                banjin_buliang = banjin_buliang + arr(i, 9)
            ElseIf arr(i, 10) = "亚克力" Then
                yakeli = yakeli + arr(i, 6)
                yakeli_buliang = yakeli_buliang + arr(i, 9)
            End If
            If Not d.exists(arr(i, 13)) Then
                n = n + 1
                d(arr(i, 13)) = n
                brr(n, 1) = arr(i, 13)
            End If
            If arr(i, 11) <> Empty Then
                If d.exists(arr(i, 11)) Then
'                    m = m + 1
'                    d(arr(i, 11)) = m
'                    brr(1, m) = arr(i, 11)
                    y = d(arr(i, 11))
                End If
            End If
            x = d(arr(i, 13))
'            y = d(arr(i, 11))
            brr(x, 100) = brr(x, 100) + 1
            brr(x, 2) = brr(x, 2) + arr(i, 6)
            brr(x, 3) = brr(x, 3) + arr(i, 9)
            If y <> Empty Then brr(x, y) = brr(x, y) + arr(i, 9): y = Empty: brr(x, 99) = brr(x, 99) + 1
        End If
    Next
    For i = 1 To n
         brr(i, 13) = Format(1 - brr(i, 3) / brr(i, 2), "0.00%")
         brr(i, 14) = Format(1 - brr(i, 99) / brr(i, 100), "0.00%")
         brr(i, 15) = "=VLOOKUP(" & brr(i, 13) & ",{0,""E级"";0.8,""D级"";0.85,""C级"";0.9,""B级"";0.95,""A级""},2)"
    Next
    If n <= r Then
        sh.[a4].Resize(r, UBound(biaoti, 2)) = ""
        sh.[a4].Resize(n, UBound(biaoti, 2)) = brr
    Else
        sh.Cells(r + 4, 1).Resize(n - r, UBound(biaoti, 2)).Insert xlShiftDown
        sh.[a4].Resize(r, UBound(biaoti, 2)) = ""
        sh.[a4].Resize(n, UBound(biaoti, 2)) = brr
    End If
    sh.[h1] = hang: sh.[j1] = zong
    sh.[b2] = 1 - jijia_buliang / jijia
    sh.[d2] = 1 - banjin_buliang / banjin
    sh.[f2] = 1 - yakeli_buliang / yakeli
    sh.[h2] = 1 - daban_buliang / daban
    sh.[j2] = 1 - buliang / zong
    Set d = Nothing
    Beep
End Sub

淘气的萝卜

quqiyuan 发表于 2024-12-5 15:38
增加你这些需求，你测试一下咯，有可能对要求理解有偏差。仅供参考。。。

~~~~~~完美完美~~~~~~~