[已解决]按条件提取日期及数量

wxfwxj

求助.zip (9.86 KB, 下载次数: 6)

2016-4-17 11:33 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2016-4-17 12:13

Sub test()
    Dim A, B, d1, i, j, c, str
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    For j = 2 To 3
        A = Sheets(j).UsedRange: c = UBound(A, 2)
        For i = 1 To UBound(A)
            d1(A(i, c - 1)) = d1(A(i, c - 1)) & A(i, c)
            d2(A(i, c - 1)) = d2(A(i, c - 1)) & ", " & A(i, 1)
        Next i
    Next j

    Sheets(1).Activate
    A = Range("b3").CurrentRegion
    For i = 2 To UBound(A)
        A(i, 2) = 0
        str = d1(A(i, 1))
        str = VBA.Replace(str, "块", ",")
        str = VBA.Replace(str, "套", ",")
        B = VBA.Split(str, ",")
        For j = 0 To UBound(B) - 1
            A(i, 2) = A(i, 2) + B(j)
        Next j
        A(i, 3) = Mid(d2(A(i, 1)), 3)
    Next i
    [b3].Resize(UBound(A), UBound(A, 2)) = A
End Sub

求助4.rar (13.21 KB, 下载次数: 20)

2016-4-17 12:14 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

Sub test()
    Dim A, B, d, i, j, c
    Set d = CreateObject("scripting.dictionary")
    For j = 2 To 3
        A = Sheets(j).UsedRange: c = UBound(A, 2)
        For i = 1 To UBound(A)
            d(A(i, c - 1)) = d(A(i, c - 1)) & A(i, c)
        Next i
    Next j

    A = Sheets(1).Range("b3").CurrentRegion
    For i = 2 To UBound(A)
        A(i, 2) = 0
        B = VBA.Split(d(A(i, 1)), "块")
        For j = 0 To UBound(B) - 1
            A(i, 2) = A(i, 2) + B(j)
        Next j
    Next i
    [b3].Resize(i - 1, 2) = A
End Sub

求助2.rar (14.21 KB, 下载次数: 4)

2016-4-17 12:00 上传

点击文件名下载附件

爱疯

Sub test2()
    Dim A, B, d, i, j, c, str
    Set d = CreateObject("scripting.dictionary")
    For j = 2 To 3
        A = Sheets(j).UsedRange: c = UBound(A, 2)
        For i = 1 To UBound(A)
            d(A(i, c - 1)) = d(A(i, c - 1)) & A(i, c)
        Next i
    Next j

    Sheets(1).Activate
    A = Range("b3").CurrentRegion
    For i = 2 To UBound(A)
        A(i, 2) = 0
        str = d(A(i, 1))
        str = VBA.Replace(str, "块", ",")
        str = VBA.Replace(str, "套", ",")
        B = VBA.Split(str, ",")
        For j = 0 To UBound(B) - 1
            A(i, 2) = A(i, 2) + B(j)
        Next j
    Next i
    [b3].Resize(i - 1, 2) = A
End Sub

求助3.rar (13.74 KB, 下载次数: 2)

2016-4-17 12:05 上传

点击文件名下载附件

单位好像不止一种，改下。

wxfwxj

爱疯 发表于 2016-4-17 12:00
Sub test()
    Dim A, B, d, i, j, c
    Set d = CreateObject("scripting.dictionary")

你好，我想要的是每次的数量 及日期

爱疯

Sub test()
    Dim A, B, d1, i, j, c, str
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    For j = 2 To 3
        A = Sheets(j).UsedRange: c = UBound(A, 2)
        For i = 1 To UBound(A)
            d1(A(i, c - 1)) = d1(A(i, c - 1)) & A(i, c)
            d2(A(i, c - 1)) = d2(A(i, c - 1)) & ", " & A(i, 1)
        Next i
    Next j

    Sheets(1).Activate
    A = Range("b3").CurrentRegion
    For i = 2 To UBound(A)
        A(i, 2) = 0
        str = d1(A(i, 1))
        str = VBA.Replace(str, "块", ",")
        str = VBA.Replace(str, "套", ",")
        B = VBA.Split(str, ",")
        For j = 0 To UBound(B) - 1
            A(i, 2) = A(i, 2) + B(j)
        Next j
        A(i, 3) = Mid(d2(A(i, 1)), 3)
    Next i
    [b3].Resize(UBound(A), UBound(A, 2)) = A
End Sub

求助4.rar (13.21 KB, 下载次数: 20)

2016-4-17 12:14 上传

点击文件名下载附件