提取数据并汇总

lidayu

恳请老师赐教，要如何实现提取数据后汇总，详情附件。
201215变更格式出现类型不匹配.part1.rar (1000 KB, 下载次数: 7)

2020-12-16 13:29 上传

点击文件名下载附件
201215变更格式出现类型不匹配.part2.rar (424.11 KB, 下载次数: 8)

2020-12-16 13:29 上传

点击文件名下载附件
昨天附件上传错了，已重新更新

shuidisyy

lidayu 发表于 2020-12-16 20:51
shuidisyy您好，这是我手工做的失误，第一条应该与第三条一样，有劳您了谢谢！

Sub test()
    Dim arrData, arrResult, dic As Object, d As Object, arrList
    Dim x&, irow&, i&, n&, j%, str$, m$, s1#, s2#, ss$
    Set dic = CreateObject("Scripting.Dictionary")
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet6
        irow = .Range("x" & Rows.Count).End(xlUp).Row
        arrList = .Range("x3:ac" & irow).Value
         For i = 1 To UBound(arrList)
            dic(arrList(i, 1) & "," & arrList(i, 2) & "," & arrList(i, 3)) = i
            dic(arrList(i, 1) & "," & arrList(i, 3)) = arrList(i, 4)
         Next i
    End With

    With Sheet3
        irow = .Range("d" & Rows.Count).End(xlUp).Row
        arrData = .Range("a3:t" & irow).Value
        ReDim arrResult(1 To UBound(arrData), 1 To 17)
    End With
    For i = 2 To UBound(arrData)
        If arrData(i, 1) = "" Then
            arrData(i, 1) = arrData(i - 1, 1)
            arrData(i, 2) = arrData(i - 1, 2)
            arrData(i, 3) = arrData(i - 1, 3)
        End If
        If arrData(i, 13) <> "" Then
            str = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 4) & arrData(i, 5)
            If Not d.exists(str) Then
                n = n + 1
                d(str) = n
                For j = 1 To 5
                    arrResult(n, j) = arrData(i, j)
                Next j
                If Not VBA.IsNumeric(Right(arrData(i, 13), 1)) Then
                    arrResult(n, 17) = Right(arrData(i, 13), 1)
                End If
            End If
            x = d(str)
            m = Right(arrData(i, 13), 1)
            If VBA.IsNumeric(m) Then m = ""
            arrResult(x, 6) = arrResult(x, 6) + Val(Replace(arrData(i, 13), m, ""))
            ss = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 4)
            If Not d.exists(ss) Then
               d(ss) = d(str)
            End If
            x = d(ss)
            arrResult(x, 8) = arrResult(x, 8) + arrData(i, 14)
            arrResult(x, 10) = arrResult(x, 10) + arrData(i, 15)
        End If
    Next i
    For i = 1 To n
        str = arrResult(i, 3) & "," & arrResult(i, 4) & "," & arrResult(i, 5)
        If dic.exists(str) Then
            If arrList(dic(str), 4) <> "" Then
                arrResult(i, 7) = arrList(dic(str), 4)
            End If
            If arrList(dic(str), 5) <> "" Then
                arrResult(i, 13) = arrList(dic(str), 5)
                arrResult(i, 14) = arrList(dic(str), 6)
                arrResult(i, 15) = arrResult(i, 6) * arrResult(i, 14)
            End If
        End If
        If arrResult(i, 8) <> 0 Then
            str = arrResult(i, 3) & "," & arrData(1, 14)
            If dic.exists(str) Then arrResult(i, 9) = dic(str)
            s1 = arrResult(i, 9) * arrResult(i, 8)
        End If
        If arrResult(i, 10) <> 0 Then
            str = arrResult(i, 3) & "," & arrData(1, 15)
            If dic.exists(str) Then arrResult(i, 11) = dic(str)
            s2 = arrResult(i, 10) * arrResult(i, 11)
        End If
        arrResult(i, 12) = arrResult(i, 6) * arrResult(i, 7) + s1 + s2
        s1 = 0: s2 = 0
        If arrResult(i, 17) = "m" Then
            arrResult(i, 6) = Format(arrResult(i, 6), "0.00") & arrResult(i, 17)
        Else
            arrResult(i, 6) = Format(arrResult(i, 6), "0.0000") & arrResult(i, 17)
        End If
    Next i
    With Sheet5
         irow = .Range("a" & Rows.Count).End(xlUp).Row
         If irow > 2 Then .Range("a3:o" & irow).ClearContents
        .Range("a3").Resize(n, 15) = arrResult
    End With
End Sub

lidayu

昨晚把附件给上传错了，现已更新请老师帮助。

shuidisyy

lidayu 发表于 2020-12-16 17:11
昨晚把附件给上传错了，现已更新请老师帮助。

第1，3条是一样的，为啥第1条没有中介费，怎样判断

lidayu

shuidisyy 发表于 2020-12-16 19:46
第1，3条是一样的，为啥第1条没有中介费，怎样判断

shuidisyy

您好，这是我手工做的失误，第一条应该与第三条一样，有劳您了谢谢！

lidayu

shuidisyy 发表于 2020-12-16 20:57
Sub test()
    Dim arrData, arrResult, dic As Object, d As Object, arrList
    Dim x&, irow&, i& ...

shuidisyy老师

您好，非常感谢您再三的帮助，完美实现结果。

lidayu

shuidisyy 发表于 2020-12-15 21:33
Sub test()
    Dim arrData, arrResult, dic As Object, d As Object, arrList
    Dim x&, irow&, i& ...

shuidisyy老师您好，请再帮我修正下，"销售总表"F列数值后的单位出现"个"、"包"、"吨"、 "瓶"保留为整数，例如：（9瓶、10个）
谢谢

！
201216变更格式出现类型不匹配.part1.rar (900 KB, 下载次数: 8)

2020-12-16 22:26 上传

点击文件名下载附件
201216变更格式出现类型不匹配.part2.rar (534.14 KB, 下载次数: 8)

2020-12-16 22:26 上传

点击文件名下载附件

lidayu

shuidisyy 发表于 2020-12-16 19:46
第1，3条是一样的，为啥第1条没有中介费，怎样判断

shuidisyy老师您好，请再帮我修正下，"销售总表"F列数值后的单位出现"个"、"包"、"吨"、 "瓶"保留为整数，例如：（9瓶、10个）
谢谢

！

shuidisyy

lidayu 发表于 2020-12-17 21:46
shuidisyy老师您好，请再帮我修正下，"销售总表"F列数值后的单位出现"个"、"包"、"吨"、 "瓶"保留为整数 ...

        改一下这里
        If arrResult(i, 17) = "m" Then
            arrResult(i, 6) = Format(arrResult(i, 6), "0.00") & arrResult(i, 17)
        ElseIf arrResult(i, 17) = "㎡" Then
            arrResult(i, 6) = Format(arrResult(i, 6), "0.0000") & arrResult(i, 17)
        Else
            arrResult(i, 6) = Val(arrResult(i, 6)) & arrResult(i, 17)
        End If

lidayu

shuidisyy 发表于 2020-12-17 21:52
改一下这里
        If arrResult(i, 17) = "m" Then
            arrResult(i, 6) = Format(a ...

shuidisyy

老师您好，完美实现理想结果，非常感谢您热心帮助。