|
楼主 |
发表于 2018-3-25 21:15
|
显示全部楼层
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
你看看是不是哪里有问题,我这里显示的始终不对 |
|