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

whoisghost · 发表于 2018-3-23 23:27

jiaxinl 发表于 2018-3-23 17:31
是我理解错了，我明天做帮做

非常感谢。谢谢你的帮助

jiaxinl · 发表于 2018-3-24 11:46

whoisghost 发表于 2018-3-23 23:27
非常感谢。谢谢你的帮助

Sub 整理_排序_计数_2()
Dim d, r, mh, sr$, i&, j&, k&, m&, n&, x&, y&, p&
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 = .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 '装入字典并计数
                  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) '转置字典的项目写入单元格
      .Range("AA" & d.Count) = .Range("AA" & d.Count) & Right(sr, Len(sr) - mh(0).FirstIndex - 1)
      .Sort.SortFields.Clear
      .Sort.SortFields.Add Key:=Range("AA1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      With .Sort '排序
         .SetRange Range("AA1:AB" & d.Count - 1)
         .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 To 12)
      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 If0
      Next i
      .Range("A1").Resize(UBound(brr), 12) = brr
End With
Set d = Nothing
Set r = Nothing
MsgBox "整理-排序-计数  已完成！", 64, "提示！"
End Sub

whoisghost · 发表于 2018-3-24 17:24

jiaxinl 发表于 2018-3-24 11:46
Sub 整理_排序_计数_2()
Dim d, r, mh, sr$, i&, j&, k&, m&, n&, x&, y&, p&
Set d = CreateO ...

非常的感谢，谢谢你的帮助。谢谢

whoisghost · 发表于 2018-3-24 17:29

jiaxinl 发表于 2018-3-24 11:46
Sub 整理_排序_计数_2()
Dim d, r, mh, sr$, i&, j&, k&, m&, n&, x&, y&, p&
Set d = CreateO ...

还要在麻烦你一下了，在最后一行能不能在加入一个总计（就是计算所有数量的和）

hhjjpp · 发表于 2018-3-24 17:48

whoisghost 发表于 2018-3-23 23:26
非常感谢你的帮助，不过你发的东西我感觉好像我看不太懂。

substitute把多元的分隔符单一化为逗号，然后把2-3个逗号换成1个
然后就是按分隔符取数
再对上述数值排序
……

jiaxinl · 发表于 2018-3-24 18:27

whoisghost 发表于 2018-3-24 17:29
还要在麻烦你一下了，在最后一行能不能在加入一个总计（就是计算所有数量的和）

放入模块3中，你试试看

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 '装入字典并计数
                  z j=zj + 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

whoisghost · 发表于 2018-3-24 19:56

jiaxinl 发表于 2018-3-24 18:27
放入模块3中，你试试看

Sub 整理_排序_计数_2()

编译错误，子过程或函数未定义

whoisghost · 发表于 2018-3-24 20:05

jiaxinl 发表于 2018-3-24 18:27
放入模块3中，你试试看

Sub 整理_排序_计数_2()

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 '装入字典并计数
               z j=zj + 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 · 发表于 2018-3-24 20:52

本帖最后由 jiaxinl 于 2018-3-24 20:58 编辑

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

我在手机上直接输的
中间多了一个空格，你再试试看
z j=zj + 1

改为

zj=zj + 1

whoisghost · 发表于 2018-3-24 21:36

jiaxinl 发表于 2018-3-24 20:52
我在手机上直接输的
中间多了一个空格，你再试试看
z j=zj + 1

总计的结果一直都是1，不能全部统计出来

		自动登录	找回密码
密码			免费注册

[建议&疑问] 求助，如何一次整理排序计数啊