周数問題........................

cmo9020

请导师帮忙一下，目前要修周数
把sheet1的相同年份资料给带出来
一直出现问题,资料带不出来
麻烦请导师帮忙看一下,谢谢


Sub TEST()
    Dim d As Object, dc As Object
    Dim ar As Variant, br As Variant
    Set d = CreateObject("scripting.dictionary")
    Set dc = CreateObject("scripting.dictionary")
    Tt = Timer
    With Sheets("Sheet1")
        r = .Cells(Rows.count, 3).End(xlUp).Row
        ar = .Range("a1:n" & r)
    End With
With Sheets("Sheet2")
        nf = .[A1]
        rs = .Cells(Rows.count, 1).End(xlUp).Row
        If rs > 3 Then
            .Range("O4:AA" & rs).Borders.LineStyle = 0
            .Range("O4:AA" & rs) = 0
        End If
        u = UBound(ar) + 4
        br = .Range("O3:AA" & u).Value2
        br = WorksheetFunction.IfError(br, 0)
        For j = 2 To UBound(br, 2)
            If Trim(br(1, j)) <> "" Then
                d(Trim(br(1, j))) = j
            End If
        Next j
        k = 1
        For i = 2 To UBound(ar)
            If Year(ar(i, 3)) = nf Then
                If Trim(ar(i, 1)) <> "" Then dc(Trim(ar(i, 1))) = dc(Trim(ar(i, 1))) + 1
                If Trim(ar(i, 1)) <> "" And Trim(ar(i, 12)) <> "" Then
                    t = d(Trim(ar(i, 12)))
                    If t = "" Then
            k = k + 1
                        d(Trim(ar(i, 12))) = k
                        t = k
                        br(k, 1) = ar(i, 12)
                    End If
                    lh = d(Trim(ar(i, 1)))
                    If lh <> "" Then
                        br(t, lh) = br(t, lh) + 1
                    End If
                End If
            End If
        Next i
        k = k + 1
        br(k, 1) = "不良总数"
        br(k + 1, 1) = " 每月检验笔数"
        br(k + 2, 1) = " 不良率"
For j = 2 To UBound(br, 2)
            br(k, j) = Application.Sum(Application.Index(br, 0, j))
            lh = d(Trim(br(1, j)))
            br(k + 1, j) = dc(Trim(br(1, j)))
            If br(k + 1, j) = 0 Then
                br(k + 2, j) = 0
              br(k + 1, j) = 0
            Else
                br(k + 2, j) = br(k, j) / br(k + 1, j)
            End If
        Next j
        .[O3].Resize(k + 2, UBound(br, 2)) = br
        .Cells(k + 4, 2).Resize(1, 12).NumberFormatLocal = "0.0%"
        .[O3].Resize(k + 2, UBound(br, 2)).Borders.LineStyle = 2
    End With
    Set d = Nothing
    Set dc = Nothing

End Sub

洋务德雷

看一下是不是这个结果。vba+sql快速解决

cmo9020

洋务德雷 发表于 2023-1-12 22:18
看一下是不是这个结果。vba+sql快速解决

导师您好,谢谢导师的帮忙
不过我还是希望以原来的代码进行查询

不然我不懂那么多代码,记性也不好
修改一个代码都要花比别人多的时间去做修改
还是谢谢您的帮忙,感恩