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

whoisghost

想帮老婆弄一个简易的表格，她基本不会用EXCLE，她的工作是把别人发过来的货号配货，可是别人总是发过来的乱七八糟的，她配货时间总是非常久而且会出错，所以想帮她弄一个，求高手教教我改怎么弄。以下是别人发过来的货号：
001,002,008,010,019,017,021,022,025,048,053,029,042,028,112,111,095,019,196,195,
229,448,431,459,432,261,011,012,013,014,
016,017,018,019,030,037,089,090,094,096,
101,102,104,129,128,131,162,152,432,443,
198,209,221,223,142,143,159,115,122,127,
087,095,111,058,074,080,037,054,005,022,
002,019,029,,031,,037,,038,,041,,056,087,093,
,095,,118,,129,,174,,184,,190,,214 , 260, 260, 260,
412.196..118..120..098.019..033..017..194..229..
108, 111, 112, 113, 115, 117, 118, 119, 120, 127,
128, 129, 135, 072, 075, 076, 077, 080,081, 091,
092, 097, 099, 100, 435, 441, 443,448, 453.228
185
191
252
119
049
433
261
264
266
102
别人发过来的是又乱又没有规则，符号也不统一，我该怎么弄才能让我老婆能傻瓜式的一键整理排序计数呢？

jiaxinl

代码如下:

Sub 整理排序()    Dim d, sr$, filter$, fileToOpen    filter = "Text Files(*.txt),*.txt "    fileToOpen = Application.GetOpenFilename(filefilter:=filter, FilterIndex:=2, Title:="请选择文件")       '打开文件    Set d = CreateObject("scripting.dictionary")     '引用字典    With Sheet1        .UsedRange.ClearContents            '清除原有的数据        Open fileToOpen For Input As #1     '使用open语句输入            Do While Not EOF(1)   '运行到文件的结尾结束                Line Input #1, sr           '按行读取数据                Set r = CreateObject("VBScript.Regexp") '正则                 r.Pattern = "(\d+)" '正则表达式l:                 If r.test(sr) Then '能匹配数字                    Set mh = r.Execute(sr)                    d(mh(0).submatches(0)) = ""  '装入字典                    sr = r.Replace(sr, "$") '替换已提取的数字                    GoTo l                 End If            Loop        Close #1   '关闭文本文件        .Range("A1").Resize(d.Count, 1) = Application.Transpose(d.keys) '转置字典的关键字写入单元格        .Sort.SortFields.Clear        .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal        With .Sort '排序            .SetRange Range("A1:A" & d.Count)            .Apply        End With    End With    Set d = NothingEnd Sub

jiaxinl

代码如下:

Sub 整理排序()    Dim d, sr$, filter$, fileToOpen    filter = "Text Files(*.txt),*.txt "    fileToOpen = Application.GetOpenFilename(filefilter:=filter, FilterIndex:=2, Title:="请选择文件")       '打开文件    Set d = CreateObject("scripting.dictionary")     '引用字典    With Sheet1        .UsedRange.ClearContents            '清除原有的数据        Open fileToOpen For Input As #1     '使用open语句输入            Do While Not EOF(1)   '运行到文件的结尾结束                Line Input #1, sr           '按行读取数据                Set r = CreateObject("VBScript.Regexp") '正则                 r.Pattern = "(\d+)" '正则表达式l:                 If r.test(sr) Then '能匹配数字                    Set mh = r.Execute(sr)                    d(mh(0).submatches(0)) = ""  '装入字典                    sr = r.Replace(sr, "$") '替换已提取的数字                    GoTo l                 End If            Loop        Close #1   '关闭文本文件        .Range("A1").Resize(d.Count, 1) = Application.Transpose(d.keys) '转置字典的关键字写入单元格        .Sort.SortFields.Clear        .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal        With .Sort '排序            .SetRange Range("A1:A" & d.Count)            .Apply        End With    End With    Set d = NothingEnd Sub

jiaxinl

Sub 整理排序()   
Dim d, sr$, filter$, fileToOpen   
filter = "Text Files(*.txt),*.txt "   
fileToOpen = Application.GetOpenFilename(filefilter:=filter, FilterIndex:=2, Title:="请选择文件")       '打开文件   
Set d = CreateObject("scripting.dictionary")     '引用字典   
With Sheet1        
.UsedRange.ClearContents            '清除原有的数据        
Open fileToOpen For Input As #1     '使用open语句输入            Do While Not EOF(1)   '运行到文件的结尾结束               
Line Input #1, sr           '按行读取数据               
Set r = CreateObject("VBScript.Regexp") '正则                 r.Pattern = "(\d+)" '正则表达式l:                 
If r.test(sr) Then '能匹配数字                    
Set mh = r.Execute(sr)                    
d(mh(0).submatches(0)) = ""  '装入字典                    
sr = r.Replace(sr, "$") '替换已提取的数字                    
GoTo l                 
End If            
Loop        
Close #1   '关闭文本文件        
.Range("A1").Resize(d.Count, 1) = Application.Transpose(d.keys) '转置字典的关键字写入单元格        .Sort.SortFields.Clear        
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal        
With .Sort '排序            
.SetRange Range("A1:A" & d.Count)            
.Apply        
End With   
End With   
Set d = Nothing
End Sub

whoisghost

谢谢您高手，那么请问，这个把整理和排序都弄好了，其中把同序号都合并了，计数部分怎么显示出来呢？

whoisghost

就是整理排序计数做成我这样的意思，一个按键就能出来，因为我老婆不怎么会电脑。谢谢高手

whoisghost

jiaxinl 发表于 2018-3-23 15:13
代码如下:

Sub 整理排序()    Dim d, sr$, filter$, fileToOpen    filter = "Text Files(*.txt),*.txt  ...

就是整理排序计数做成我这样的意思，一个按键就能出来，因为我老婆不怎么会电脑。谢谢高手

jiaxinl

whoisghost 发表于 2018-3-23 16:49
就是整理排序计数做成我这样的意思，一个按键就能出来，因为我老婆不怎么会电脑。谢谢高手

是我理解错了，我明天做帮做

hhjjpp

Book1-h.rar (9.44 KB, 下载次数: 4)

2018-3-23 22:43 上传

点击文件名下载附件

whoisghost

hhjjpp 发表于 2018-3-23 22:43

非常感谢你的帮助，不过你发的东西我感觉好像我看不太懂。