销售表

晶阳

洋务德雷 发表于 2024-1-4 10:47
使用excel运行应该没问题。不要使用wps

哦，我用的WPS，好的，谢谢

洋务德雷

晶阳 发表于 2024-1-4 20:12
哦，我用的WPS，好的，谢谢

你的信息里面写的是Office版本2016/2019，应该修改一下你的信息。以免引起误会。

3190496160

Sub 单位查询()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim arr(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("销售明细")
    r = .Cells(Rows.Count, 3).End(xlUp).Row
    If r < 7 Then MsgBox "销售明细为空！": End
    ar = .Range(.Cells(6, 1), .Cells(r, 13))
End With
With Sheets("收款明细")
    rs = .Cells(Rows.Count, 3).End(xlUp).Row
    If rs < 2 Then MsgBox "收款明细为空！": End
    br = .Range(.Cells(1, 1), .Cells(rs, 8))
End With
ReDim arr(1 To UBound(ar), 1 To 8)
ReDim brr(1 To UBound(ar), 1 To 3)
With Sheets("单位查询")
    kh = .[c1]
    xs = .[h1]
    ks = .[j1]
    js = .[l1]
    rr_1 = Array(kh, 5, xs, 12, ks, 3, js, 3)
    rr_2 = Array(kh, 4, xs, 8, ks, 3, js, 3)
    ReDim mr_1(1 To 4, 1 To 2)
    ReDim mr_2(1 To 4, 1 To 2)
    For i = 0 To UBound(rr_1) Step 2
        If rr_1(i) <> "" Then
            n = n + 1
            mr_1(n, 1) = rr_1(i)
            mr_1(n, 2) = rr_1(i + 1)
            
            mr_2(n, 1) = rr_2(i)
            mr_2(n, 2) = rr_2(i + 1)
        End If
    Next i
    If n = "请至少输入一个查询条件！" Then MsgBox "": End
    For i = 2 To UBound(ar)
        m = 0
        If ks <> "" And js <> "" Then
            If ar(i, 3) >= ks Then
                m = m + 1
            End If
            If ar(i, 3) <= js Then
                m = m + 1
            End If
        End If
        For s = 1 To n
            zd = mr_1(s, 1)
            lh = mr_1(s, 2)
            If lh <> 3 Then
                If Trim(ar(i, lh)) = Trim(zd) Then
                    m = m + 1
                End If
            End If
        Next s
        If m = n Then
            w = w + 1
            arr(w, 1) = w
            arr(w, 2) = ar(i, 3)
            For j = 6 To 11
                arr(w, j - 3) = ar(i, j)
            Next j
        End If
    Next i
    For i = 2 To UBound(br)
        m = 0
        If ks <> "" And js <> "" Then
            If br(i, 3) >= ks Then
                m = m + 1
            End If
            If br(i, 3) <= js Then
                m = m + 1
            End If
        End If
        For s = 1 To n
            zd = mr_1(s, 1)
            lh = mr_1(s, 2)
            If lh <> 3 Then
                If Trim(br(i, lh)) = Trim(zd) Then
                    m = m + 1
                End If
            End If
        Next s
        If m = n Then
            ww = ww + 1
            brr(ww, 1) = br(i, 3)
            brr(ww, 2) = br(i, 5)
            brr(ww, 3) = br(i, 6)
        End If
    Next i
    ms = .Cells(Rows.Count, 3).End(xlUp).Row
    If ms >= 5 Then .Range("a5:l" & ms).Borders.LineStyle = 0: .Range("a5:l" & ms) = Empty
    If w <> "" Then
        .[a5].Resize(w, UBound(arr, 2)) = arr
        .[a5].Resize(w, UBound(arr, 2)).Borders.LineStyle = 1
    End If
    If ww <> "" Then
        .[i5].Resize(ww, UBound(brr, 2)) = brr
        .[i5].Resize(ww, UBound(brr, 2) + 1).Borders.LineStyle = 1
    End If
End With
If w = "" Then w = 0
If ww = "" Then ww = 0
Application.ScreenUpdating = True
MsgBox "符合条件的数据有：" & Chr(10) & "销售明细:" & w & "行" & Chr(10) & "收款明细:" & ww & "行"
End Sub

3190496160

销售明细.rar (211.1 KB, 下载次数: 11)

2024-1-5 08:44 上传

点击文件名下载附件

晶阳

洋务德雷 发表于 2024-1-4 22:34
你的信息里面写的是Office版本2016/2019，应该修改一下你的信息。以免引起误会。

哦，好的，以后会注意，感谢哈

晶阳

3190496160 发表于 2024-1-5 08:44
Sub 单位查询()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant

感觉好复杂，好难

晶阳

3190496160 发表于 2024-1-5 08:46

亲苦了，太感谢了

晶阳

洋务德雷 发表于 2024-1-4 22:34
你的信息里面写的是Office版本2016/2019，应该修改一下你的信息。以免引起误会。

哦，信息修改了，谢谢哈，2016我也用，只是更喜欢用WPS