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

whoisghost · 发表于 2018-3-23 10:32

想帮老婆弄一个简易的表格，她基本不会用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 · 发表于 2018-3-23 15:12

代码如下:

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 · 发表于 2018-3-23 15:13

代码如下:

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 · 发表于 2018-3-23 15:17

本帖最后由 jiaxinl 于 2018-3-23 16:08 编辑

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