高难度的合并计算

xpw6061

yty773436272 发表于 2012-1-5 20:07
当我在上面随便输入一个下面没有的内容，下面显示代码出错，采购数量是不能相加的，上面的查询条件希望输 ...

晕死,咋不把自己的要求说明白,具体点,还以为只有符合三个相同条件的才查询,你的意思是只要在三个单元格中输入一个条件,或者二条件都要查,并且只列出符合条件的记录,而不需要统计相关记录,有多条列出多条,范围是从前面两个工作表查找符合条件的所有记录,条件全为空时,就要统计两个表中,物料编号,供货厂家,日期三项相同完全相同的相关数据,是这么个意思吧,采购数量不相加是在查询某条记录时不相加,但在统计时相加吧,这个意思是我猜你的意图,你的要求是统计?还是查询?或者统计,查询都想要,有时要统计,有时要查询,

yty773436272

xpw6061 发表于 2012-1-5 20:25
晕死,咋不把自己的要求说明白,具体点,还以为只有符合三个相同条件的才查询,你的意思是只要在三个单元格中 ...

我用下面的代码解决啦
Sub aa()
Dim d, arr, brr, crr(), cr(), i, j, m, a, b, c, s, x, y
arr = Sheet5.Range("a3", Sheet5.[q65536].End(3))
brr = Sheet3.Range("a3", Sheet3.[q65536].End(3))
ReDim crr(1 To UBound(arr), 1 To 16)
Set d = CreateObject("Scripting.Dictionary")
m = 0
For i = 1 To UBound(arr)
    s = arr(i, 1) & arr(i, 6) & arr(i, 8)
    If Not d.Exists(s) Then
       m = m + 1
       d(s) = m
       For j = 1 To 6
           crr(m, j) = arr(i, j)
       Next
       crr(m, 7) = arr(i, 8)
       crr(m, 9) = arr(i, 9)
       crr(m, 11) = arr(i, 12)
       crr(m, 13) = arr(i, 17)
    Else
       crr(d(s), 9) = crr(d(s), 9) + arr(i, 9)
       crr(d(s), 11) = crr(d(s), 11) + arr(i, 12)
       crr(d(s), 13) = crr(d(s), 13) + arr(i, 17)
    End If
Next
For i = 1 To UBound(brr)
    s = brr(i, 1) & brr(i, 6) & brr(i, 8)
    If d.Exists(s) Then
       crr(d(s), 8) = brr(i, 9)
       crr(d(s), 15) = crr(d(s), 15) + brr(i, 17)
       crr(d(s), 16) = crr(d(s), 16) + brr(i, 14)
    End If
       crr(d(s), 10) = crr(d(s), 8) - crr(d(s), 9)
       crr(d(s), 12) = crr(d(s), 9) - crr(d(s), 11)
       crr(d(s), 14) = crr(d(s), 11) - crr(d(s), 13)
Next
With Sheet4
    If .[a2] = "" Then a = "*" Else a = .[a2].Value
    If .[b2] = "" Then b = "*" Else b = .[b2].Value
    If .[c2] = "" Then c = "*" Else c = .[c2].Value
     x = a & "," & b & "," & c
    ReDim cr(1 To m, 1 To 16)
    For i = 1 To m
        y = crr(i, 1) & "," & crr(i, 6) & "," & crr(i, 7)
        If y Like x Then
           n = n + 1
           For j = 1 To 16
               cr(n, j) = crr(i, j)
           Next
        End If
    Next
   
    Sheet4.UsedRange.Offset(4).Borders.LineStyle = 0
    Sheet4.UsedRange.Offset(4).Clear
    If n > 0 Then
       .[a5].Resize(n, 16) = cr
       .[a5].Resize(n, 16).Borders.LineStyle = 1
       .[a5].Resize(n, 16).HorizontalAlignment = xlCenter
       .[a5].Resize(n, 16).VerticalAlignment = xlCenter '
      Cells.Select
    With Selection.Font
        .Name = "宋体"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Font
        .Name = "宋体"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A1").Select
    Else
       MsgBox "未找到匹配的数据！"
    End If
End With
Set d = Nothing
End Sub