求大神帮忙！！！！！

zhouzhongchi

zhouzhongchi 发表于 2015-9-10 22:51
我这里可以呢？

1. Sub test()
   
2. Dim sht As Worksheet
   
3. arr = Sheets("sheet1").[a1].CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5. Set d = CreateObject("scripting.dictionary")
   
6. For i = 2 To UBound(arr)
   
7. If Len(arr(i, 1)) = 5 Then
   
8. If Mid(arr(i, 1), 3, 1) > "6" Then Mid(arr(i, 1), 3, 1) = 6
   
9. Else
   
10. arr(i, 1) = Mid(arr(i, 1), 6, 5)
    
11. End If
    
12. If Not d.exists(arr(i, 1)) Then
    
13. m = m + 1: d(arr(i, 1)) = m: brr(m, 1) = arr(i, 1):
    
14. For j = 2 To UBound(arr, 2)
    
15. brr(m, j) = arr(i, j)
    
16. Next
    
17. Else
    
18. For j = 2 To UBound(arr, 2)
    
19. brr(d(arr(i, 1)), j) = brr(d(arr(i, 1)), j) + arr(i, j)
    
20. Next
    
21. End If
    
22. Next
    
23. [a30].Resize(m, j - 1) = brr
    
24. Application.DisplayAlerts = False
    
25. For Each sht In Sheets
    
26. If sht.Name <> "Sheet1" Then sht.Delete
    
27. Next
    
28. Application.DisplayAlerts = True
    
29. For j = 2 To UBound(arr, 2) - 1
    
30. ReDim crr(1 To m, 1 To 2)
    
31. For i = 1 To m
    
32. crr(i, 1) = brr(i, 1)
    
33. crr(i, 2) = brr(i, j)
    
34. Next
    
35. Sheets.Add(after:=Sheets(Sheets.Count)).Name = arr(1, j)
    
36. With ActiveSheet
    
37. .[a1:b1] = Array("销售终端号", "销售金额")
    
38. .[a2].Resize(m, 2) = crr
    
39. End With
    
40. Next
    
41. 'Stop
    
42. End Sub

复制代码

朋友，你的模拟数据弄了些随机数（偷懒哈），无法检验。。。。。所以疏忽了。
这次好了吗？

zhouzhongchi

记得把第23行注释掉哈。调试过程中观察用的。

leiyu18530

zhouzhongchi 发表于 2015-9-10 22:51
我这里可以呢？

谢谢老师这么晚了还在辛苦，我再研究研究，可能是我模拟的原始数据，和我真正要统计的数据不是很一样，编号里面会出现中文，谢谢您！

zhouzhongchi

美图：

1. Sub sum_1toN()
   
2.     Dim sht As Worksheet, d As Object
   
3.     Dim i&, j&, r&, m&
   
4.     arr = Sheets("sheet1").[a1].CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1)
   
9.         Select Case Len(s)
   
10.             Case 5
    
11.                 If Mid(s, 3, 1) > "6" Then Mid(s, 3, 1) = 6
    
12.             Case 13
    
13.                 s = Mid(s, 6, 5)
    
14.             Case Else
    
15.         End Select
    
16.         arr(i, 1) = s: s = arr(i, 1)
    
17.         If Not d.exists(s) Then m = m + 1: d(s) = m: brr(m, 1) = s: r = m Else r = d(s)
    
18.         For j = 2 To UBound(arr, 2)
    
19.             brr(r, j) = brr(r, j) + arr(i, j)
    
20.         Next
    
21.     Next
    
22.     Application.ScreenUpdating = False
    
23.     For j = 2 To UBound(brr, 2) - 1
    
24.         ReDim crr(1 To m, 1 To 2)
    
25.         For i = 1 To m
    
26.             crr(i, 1) = brr(i, 1)
    
27.             crr(i, 2) = brr(i, j)
    
28.         Next
    
29.         ActAddsht arr(1, j)
    
30.         With ActiveSheet
    
31.             .[a:b].Clear
    
32.             .[a1:b1] = Array("销售终端号", "销售金额")
    
33.             .[a2].Resize(m, 2) = crr
    
34.         End With
    
35.     Next
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    
38. Function ActAddsht(ByVal sht As String)
    
39.     On Error Resume Next
    
40.     ThisWorkbook.Sheets(sht).Activate
    
41.     If Err <> 0 Then ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count)).Name = sht
    
42.     On Error GoTo 0
    
43. End Function

复制代码

leiyu18530

zhouzhongchi 发表于 2015-9-11 08:30
美图：

非常感谢老师，辛苦了！
因为在13位长编码里提出来的5位编码，也存在 7 8 9要换成6的现象   所有后面我加了句
   If Mid(s, 3, 1) > "6" Then Mid(s, 3, 1) = 6    现在能完美运行了，呵呵，谢谢老师！！！！

zhouzhongchi

leiyu18530 发表于 2015-9-11 12:37
非常感谢老师，辛苦了！
因为在13位长编码里提出来的5位编码，也存在 7 8 9要换成6的现象   所有后面我 ...

哦，粗心了，原来一直理解为“5位替换，13位截取”，少了“截取后替换"。题意不清，考试不及格。呵呵