[已解决]VB语段运行错误，求大神指教

531tommy

我需要在Sheet2中汇总，Sheet1的数据，条件符合Sheet2的B2到D2的时段。但不知为何这个位置出错 求大神指导

附件 测试1.zip (55.71 KB, 下载次数: 2)

2023-4-9 18:14 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

zjdh

2023-4-9 19:59

宏稍作修改，清除了一些不必要的语句：
Sub 销售()
    Sheet2.Range("A4:F965536").ClearContents
    Dim d, d1, arr, k As Integer, n As Integer, str
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1").CurrentRegion    '销售
    T1 = Sheet2.[B2]
    T2 = Sheet2.[D2]
    For k = 2 To UBound(arr)
        If arr(k, 5) >= T1 And arr(k, 5) <= T2 Then
            str = arr(k, 7) & "@" & arr(k, 8)
            d1(str) = d1(str) + -arr(k, 9)    '销售件数
            If Not d.exists(str) Then
                d(str) = arr(k, 8) & "|" & -arr(k, 9)    '规格/数量
            Else
                d(str) = d(str) & "、" & arr(k, 8) & "|" & -arr(k, 9)
            End If
        End If  '原来放错位置啦
    Next k
    Erase arr
    ReDim Preserve arr(1 To d1.Count, 1 To 3)
    For k = 0 To d.Count - 1
        str = Split(d.keys()(k), "@")
        n = n + 1
        arr(n, 1) = str(0)
        arr(n, 2) = d(d.keys()(k))    '规格/数量
        arr(n, 3) = d1(d1.keys()(k))    '数量
    Next k
    Sheet2.Range("A4").Resize(UBound(arr), 3) = arr
End Sub

跳转到最佳答案楼层

zjdh

运行正常啊！

zjdh

宏稍作修改，清除了一些不必要的语句：
Sub 销售()
    Sheet2.Range("A4:F965536").ClearContents
    Dim d, d1, arr, k As Integer, n As Integer, str
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1").CurrentRegion    '销售
    T1 = Sheet2.[B2]
    T2 = Sheet2.[D2]
    For k = 2 To UBound(arr)
        If arr(k, 5) >= T1 And arr(k, 5) <= T2 Then
            str = arr(k, 7) & "@" & arr(k, 8)
            d1(str) = d1(str) + -arr(k, 9)    '销售件数
            If Not d.exists(str) Then
                d(str) = arr(k, 8) & "|" & -arr(k, 9)    '规格/数量
            Else
                d(str) = d(str) & "、" & arr(k, 8) & "|" & -arr(k, 9)
            End If
        End If  '原来放错位置啦
    Next k
    Erase arr
    ReDim Preserve arr(1 To d1.Count, 1 To 3)
    For k = 0 To d.Count - 1
        str = Split(d.keys()(k), "@")
        n = n + 1
        arr(n, 1) = str(0)
        arr(n, 2) = d(d.keys()(k))    '规格/数量
        arr(n, 3) = d1(d1.keys()(k))    '数量
    Next k
    Sheet2.Range("A4").Resize(UBound(arr), 3) = arr
End Sub

531tommy

zjdh 发表于 2023-4-9 19:59
宏稍作修改，清除了一些不必要的语句：
Sub 销售()
    Sheet2.Range("A4:F965536").ClearContents

十分感谢，原来是这样，怪不得运行老是有问题