[已解决]帮忙修改代码添加个计数？

sdfsdfs

添加个计数？

最佳答案

月排行榜 / 总排行榜

sgxb123431380

2013-10-8 11:05

把代码换成
Sub abc()
    Dim d, arr, brr, s$, m$, n$, k, t, i&, x&, y&
    Sheet1.Activate
    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("g6", [m65536].End(3)).Value
    ReDim no_arr(1 To Int([m65536].End(3).Row) - 5, 1 To 1001)
    no1 = 1
    For i = 1 To UBound(arr)
       If Len(arr(i, 7)) Then
          s = "(" & arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3) & ")"
          If Not d.exists(s) Then
             d(s) = no1
             no_arr(no1, 1) = "1个"
             no_arr(no1, 1001) = 1
             no_arr(no1, 1 + no_arr(no1, 1001)) = "1个" & arr(i, 7)
             no1 = no1 + 1
          Else
            no_arr(d(s), 1) = Int(Left(no_arr(d(s), 1), Len(no_arr(d(s), 1)) - 1)) + 1 & "个"
            For j = 2 To no_arr(d(s), 1001) + 1
                If InStr(no_arr(d(s), j), arr(i, 7)) > 0 Then
                    no_arr(d(s), j) = Int(Left(no_arr(d(s), j), InStr(no_arr(d(s), j), "个") - 1)) + 1 & "个" & arr(i, 7)
                    Exit For
                End If
            Next j
            If j = no_arr(d(s), 1001) + 2 Then
                no_arr(d(s), 1001) = no_arr(d(s), 1001) + 1
                no_arr(d(s), 1 + no_arr(d(s), 1001)) = "1个" & arr(i, 7)
            End If
          End If
       End If
    Next
    k = d.keys: x = d.Count
    For y = 0 To x - 1
        If no_arr(y + 1, 1001) > 1 Then
            ls = no_arr(y + 1, 2)
            For i = 3 To no_arr(y + 1, 1001) + 1
                ls = ls & "," & no_arr(y + 1, i)
            Next i
            m = m & no_arr(y + 1, 1) & k(y) & ":" & ls & ";"
        Else
            m = m & no_arr(y + 1, 1) & k(y) & no_arr(y + 1, 2) & ";"
        End If
    Next
    d.RemoveAll
    brr = Range("p6", [p65536].End(3)).Value
    For i = 1 To UBound(brr)
       If Len(brr(i, 1)) Then d(brr(i, 1)) = ""
    Next
    n = Join(d.keys, "+")
    Application.DisplayAlerts = False
    Workbooks.Open Filename:=ThisWorkbook.Path & "\B2.xls"
    On Error Resume Next
    Set rng = Application.InputBox("111", , "$f$8", Type:=8)
    Range(rng.Address) = Left(m, Len(m) - 1)
    Range(rng.Address).Offset(, 3) = n
    Application.DisplayAlerts = True
End Sub

跳转到最佳答案楼层

sdfsdfs

帮个忙？

sdfsdfs

帮忙解决一下

sdfsdfs

顶一下

1091126096

不知你要怎样连接字符串？

sdfsdfs

哪位大师帮忙改一下

sgxb123431380

把代码换成
Sub abc()
    Dim d, arr, brr, s$, m$, n$, k, t, i&, x&, y&
    Sheet1.Activate
    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("g6", [m65536].End(3)).Value
    ReDim no_arr(1 To Int([m65536].End(3).Row) - 5, 1 To 1001)
    no1 = 1
    For i = 1 To UBound(arr)
       If Len(arr(i, 7)) Then
          s = "(" & arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3) & ")"
          If Not d.exists(s) Then
             d(s) = no1
             no_arr(no1, 1) = "1个"
             no_arr(no1, 1001) = 1
             no_arr(no1, 1 + no_arr(no1, 1001)) = "1个" & arr(i, 7)
             no1 = no1 + 1
          Else
            no_arr(d(s), 1) = Int(Left(no_arr(d(s), 1), Len(no_arr(d(s), 1)) - 1)) + 1 & "个"
            For j = 2 To no_arr(d(s), 1001) + 1
                If InStr(no_arr(d(s), j), arr(i, 7)) > 0 Then
                    no_arr(d(s), j) = Int(Left(no_arr(d(s), j), InStr(no_arr(d(s), j), "个") - 1)) + 1 & "个" & arr(i, 7)
                    Exit For
                End If
            Next j
            If j = no_arr(d(s), 1001) + 2 Then
                no_arr(d(s), 1001) = no_arr(d(s), 1001) + 1
                no_arr(d(s), 1 + no_arr(d(s), 1001)) = "1个" & arr(i, 7)
            End If
          End If
       End If
    Next
    k = d.keys: x = d.Count
    For y = 0 To x - 1
        If no_arr(y + 1, 1001) > 1 Then
            ls = no_arr(y + 1, 2)
            For i = 3 To no_arr(y + 1, 1001) + 1
                ls = ls & "," & no_arr(y + 1, i)
            Next i
            m = m & no_arr(y + 1, 1) & k(y) & ":" & ls & ";"
        Else
            m = m & no_arr(y + 1, 1) & k(y) & no_arr(y + 1, 2) & ";"
        End If
    Next
    d.RemoveAll
    brr = Range("p6", [p65536].End(3)).Value
    For i = 1 To UBound(brr)
       If Len(brr(i, 1)) Then d(brr(i, 1)) = ""
    Next
    n = Join(d.keys, "+")
    Application.DisplayAlerts = False
    Workbooks.Open Filename:=ThisWorkbook.Path & "\B2.xls"
    On Error Resume Next
    Set rng = Application.InputBox("111", , "$f$8", Type:=8)
    Range(rng.Address) = Left(m, Len(m) - 1)
    Range(rng.Address).Offset(, 3) = n
    Application.DisplayAlerts = True
End Sub

sdfsdfs

sgxb123431380 发表于 2013-10-8 11:05
把代码换成
Sub abc()
    Dim d, arr, brr, s$, m$, n$, k, t, i&, x&, y&

写的不错，谢谢

sdfsdfs

sgxb123431380 发表于 2013-10-8 11:05
把代码换成
Sub abc()
    Dim d, arr, brr, s$, m$, n$, k, t, i&, x&, y&

1 To 1001 是什么？

sdfsdfs

sgxb123431380 发表于 2013-10-8 11:05
把代码换成
Sub abc()
    Dim d, arr, brr, s$, m$, n$, k, t, i&, x&, y&

有个问题，只有重复的数据前计数，你把不重复的数据也加上了？