求助，如何一次整理排序计数啊

jiaxinl

whoisghost 发表于 2018-3-24 21:36
总计的结果一直都是1，不能全部统计出来

等一下，我在电脑上调试一下看

jiaxinl

whoisghost 发表于 2018-3-24 21:36
总计的结果一直都是1，不能全部统计出来

我再电脑上试了，是正常的结果

whoisghost

jiaxinl 发表于 2018-3-24 21:52
我再电脑上试了，是正常的结果

.....我这里试了一下，还是一样，总计还是只显示1，是我哪里改错了么

whoisghost

jiaxinl 发表于 2018-3-24 21:52
我再电脑上试了，是正常的结果

Sub 整理_排序_计数_2()
     Dim d, r, mh, sr$, i&, j&, k&, m&, n&, x&, y&, p&, rr&, zj&
     Set d = CreateObject("scripting.dictionary")     '引用字典
    With Sheet1
         .Range("A1:L" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents  '清除原有的数据
'        Application.Wait (Now + TimeValue("00:00:03")) '延迟3秒的时间再执行下句代码
        Application.ScreenUpdating = False
                 Set r = CreateObject("VBScript.Regexp") '正则
                 r.Pattern = "(\d+)" '正则表达式
                 sr = Trim(.Range("M1"))
l:     '标签L处
                 If r.test(sr) Then '能匹配数字
                    Set mh = r.Execute(sr)
                     d(mh(0).SubMatches(0)) = d(mh(0).SubMatches(0)) + 1 '装入字典并计数
                    zj = j + 1
                     sr = r.Replace(sr, "$") '替换已提取的数字
                    GoTo l '跳转到标签L处
                 End If
         .Range("AA1:AB" & .Cells(.Rows.Count, "AA").End(xlUp).Row).ClearContents  '清除原有的数据
        .Range("AA1").Resize(d.Count, 1) = Application.Transpose(d.keys) '转置字典的关键字写入单元格
        .Range("AB1").Resize(d.Count, 1) = Application.Transpose(d.items) '转置字典的项目写入单元格
       If Right(sr, 1) <> "$" Then
           .Range("AA" & d.Count) = .Range("AA" & d.Count) & Right(sr, Len(sr) - mh(0).FirstIndex - 1)
             rr = d.Count - 1
         Else
             rr = d.Count
        End If
         .Sort.SortFields.Clear
         .Sort.SortFields.Add Key:=Range("AA1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
         With .Sort '排序
            .SetRange Range("AA1:AB" & rr)
             .Apply
         End With
         arr = .Range("AA1:AB" & .Cells(.Rows.Count, "AA").End(xlUp).Row)
         .Range("AA1:AB" & .Cells(.Rows.Count, "AA").End(xlUp).Row).ClearContents
         k = Application.WorksheetFunction.RoundUp(UBound(arr) / 11, 0)
         k = Application.WorksheetFunction.RoundUp((UBound(arr) + k) / 11, 0)
         ReDim brr(1 To k * 2 + 1, 1 To 12)
         brr(k * 2 + 1, 1) = "总计"
         brr(k * 2 + 1, 2) = zj
         y = 1: n = 1: p = 1
ll:
         j = y: m = n: x = 1
         brr(m * 2 - 1, 1) = "货号"
         brr(m * 2, 1) = "数量"
         For i = j To UBound(arr) - 1
              x = x + 1
             If x > 12 Then brr((m + 1) * 2 - 1, 2) = arr(i - 1, 1): brr((m + 1) * 2, 2) = arr(i - 1, 2): y = i - 1: n = n + 1: p = 2: s = 1: GoTo ll
             If p > 1 Then
                 On Error Resume Next
                 brr(m * 2 - 1, x + 1) = arr(i + 1, 1)
                 brr(m * 2, x + 1) = arr(i + 1, 2)
             Else
                 brr(m * 2 - 1, x) = arr(i, 1)
                 brr(m * 2, x) = arr(i, 2)
             End If
         Next i
         .Range("A1").Resize(UBound(brr), 12) = brr
     End With
     Set d = Nothing
     Set r = Nothing
     MsgBox "整理-排序-计数  已完成！", 64, "提示！"
End Sub
你看看是不是哪里有问题，我这里显示的始终不对

jiaxinl

whoisghost 发表于 2018-3-25 21:15
Sub 整理_排序_计数_2()
     Dim d, r, mh, sr$, i&, j&, k&, m&, n&, x&, y&, p&, rr&, zj&
     Set ...

这句你改错了

zj = j + 1

改为

zj = zj + 1

whoisghost

jiaxinl 发表于 2018-3-25 22:43
这句你改错了

zj = j + 1

谢谢，是我疏忽了，谢谢你的帮助