更改格式后类型不匹配

shuidisyy

我在单位没法下载附件，但是，我还有点印象，我感觉你的需求又变了，就打红这个订单，我上次汇总完就是3项，你说1，3需要合并，我就改了，然后今天你又变了，你核对一下你的数据源，如果是3项，双层边49.15也应该是拆成两个，而不是都在第一项上，我不知道你的需求是啥

lidayu

shuidisyy 发表于 2020-12-14 10:37
我在单位没法下载附件，但是，我还有点印象，我感觉你的需求又变了，就打红这个订单，我上次汇总完就是3项 ...

shuidisyy

您好，数据源里是三项，这都是同一个单号及客户名称，所以49.15m不能拆开，也许是我没表达清楚，但要求一直是这样的，就运行后发现L列后数据会清除，请L列后数据不要清除。请您回家后再帮我看下，辛苦您啦，谢谢！

lidayu

shuidisyy 发表于 2020-12-14 19:38
Sub test()
    Dim arrData, arrResult, dic As Object, d As Object
    Dim x&, irow&, i&, n&, j%, ...

shuidisyy

您好，完美实现想要的结果，非常感谢您耐心的帮助。

lidayu

shuidisyy 发表于 2020-12-14 10:37
我在单位没法下载附件，但是，我还有点印象，我感觉你的需求又变了，就打红这个订单，我上次汇总完就是3项 ...

shuidisyy您好，设为已解决后代码怎么不在页面呢，我都没保存到本地，能否请您重新发送一下，谢谢！

lidayu

shuidisyy 发表于 2020-12-14 10:37
我在单位没法下载附件，但是，我还有点印象，我感觉你的需求又变了，就打红这个订单，我上次汇总完就是3项 ...

shuidisyy

老师您好，代码我没保存，页面上也没有了，请您再发次代码，谢谢！

shuidisyy

lidayu 发表于 2020-12-14 23:53
shuidisyy老师您好，代码我没保存，页面上也没有了，请您再发次代码，谢谢！

Sub test()
    Dim arrData, arrResult, dic As Object, d As Object
    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
        arrData = .Range("x3:aa" & irow).Value
         For i = 1 To UBound(arrData)
            dic(arrData(i, 1) & "," & arrData(i, 2) & "," & arrData(i, 3)) = arrData(i, 4)
            dic(arrData(i, 1) & "," & arrData(i, 3)) = arrData(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 arrResult(i, 7) = dic(str)
        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:l" & irow).ClearContents
        .Range("a3").Resize(n, 12) = arrResult
    End With
End Sub

lidayu

shuidisyy 发表于 2020-12-15 19:35
Sub test()
    Dim arrData, arrResult, dic As Object, d As Object
    Dim x&, irow&, i&, n&, j%, ...

shuidisyy老师您好，非常感谢您无私的帮助

lidayu

shuidisyy 发表于 2020-12-15 19:35
Sub test()
    Dim arrData, arrResult, dic As Object, d As Object
    Dim x&, irow&, i&, n&, j%, ...

shuidisyy

老师您好，有个新的求助帖（就是您帮完成的那个，新增了从出入库表提取数据）请您移步帮助，谢谢！

地址：http://www.excelpx.com/thread-461907-1-1.html

lidayu

shuidisyy 发表于 2020-12-15 19:35
Sub test()
    Dim arrData, arrResult, dic As Object, d As Object
    Dim x&, irow&, i&, n&, j%, ...

shuidisyy

老师您好，昨天附件上传错了，现已更新

有个新的求助帖（就是您帮完成的那个，新增了从出入库表提取数据）请您移步帮助，谢谢！

地址：http://www.excelpx.com/thread-461907-1-1.html