VBA函数实现Excel数据分解

牛宝宝吃草54335

现在有个Excel源数据，需要对Excel中数据进行分解为指定的格式，希望大神指教~
解释：

（1）源数据中有四列，首先对商品商家做筛选，需要挨个对商家数据筛选，比如先筛选“广东终端”的商家，筛选结果为
         广东终端的商品名称和手机编号。

（2）对[广东终端]商家筛选后的数据再次筛选，根据商品名称筛选，商品名称排除最后两个空格的颜色和内存属性，对比最后两个空格之前的名称，只要名称一致，即为同一款手机，比如 [TCL P620M 移动版 移动版 蓝色 16G]  和 [TCL P620M 移动版 移动版 黄色 16G]，祛除最后两个空格的 [蓝色 16G] 和 [黄色 16G]，前面的名称一致，即为同一款手机，即[TCL P620M 移动版 移动版]。

（3）经过商家和商品名称筛选后的结果，提取【手机编号】信息，换行显示，导出为 txt 格式，文件名称为商品名称+数量。例如：[TCL P620M 移动版 共22单.txt]

（4）最后按照商家名称建立一个文件夹，导出的商品名称txt文件都放入此文件夹中，导出的结果在附件中。

opiona

只实现了1/2，
后面太麻烦，没写完
新建文件夹.rar (429.6 KB, 下载次数: 6)

2016-2-16 14:22 上传

点击文件名下载附件

opiona

送上个自定义函数：
子字符串在字符串中出现N多次，截取倒数第X个之前的字符，N》x

1. Function Countss(mstr, substr, ints)
   
2.     s = mstr
   
3.     For i = 1 To ints
   
4.         s = Mid(s, 1, InStrRev(s, substr) - 1)
   
5.         If s = "" Then
   
6.             Countss = mstr
   
7.             Exit For
   
8.         End If
   
9.     Next
   
10.     Countss = s
    
11. End Function

复制代码

牛宝宝吃草54335

opiona 发表于 2016-2-16 14:23
只实现了1/2，
后面太麻烦，没写完

先学习下，感谢~

山菊花

供参考。

yangjia1980

山菊花 发表于 2016-2-16 16:27
供参考。

追着山老师跑，嘿嘿
不如我这样请教您一下，
st.Cells(j, 2) = d1(bz1)
这个语句，有什么会影响它的效率呢，
其中，st是表的别名，d1是我生成的一个字典，生成这个字典用不了1秒
但是赋值这一句，会超过1秒
谢谢

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, x$, y$, aa, j&, fso, myPath$, pa$, pa1$, nm1$
   
3. Dim d, k, t, kk, tt, f, ii&, s$
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Set fso = CreateObject("Scripting.FileSystemObject")
   
7. Sheet1.Activate
   
8. myPath = ThisWorkbook.Path & ""
   
9. Arr = [a1].CurrentRegion
   
10. For i = 2 To UBound(Arr)
    
11.     x = Arr(i, 3): y = ""
    
12.     aa = Split(Arr(i, 2))
    
13.     For j = 0 To UBound(aa) - 2
    
14.         y = y & aa(j) & " "
    
15.     Next
    
16.     If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
17.     d(x)(y) = d(x)(y) & Arr(i, 4) & ","
    
18. Next
    
19. k = d.keys: t = d.items
    
20. For i = 0 To UBound(k)
    
21.     pa = myPath & k(i): Set f = Nothing
    
22.     If Not (fso.FolderExists(pa)) Then
    
23.         Set f = fso.CreateFolder(pa)
    
24.     End If
    
25. 
    
26.     kk = t(i).keys: tt = t(i).items
    
27.     For ii = 0 To UBound(kk)
    
28.         If Not f Is Nothing Then
    
29.             pa1 = f.Path & "" & kk(ii): s = ""
    
30.         Else
    
31.             pa1 = pa & "" & kk(ii): s = ""
    
32.         End If
    
33.         tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
    
34.         If InStr(tt(ii), ",") Then
    
35.             aa = Split(tt(ii), ",")
    
36.             For j = 0 To UBound(aa)
    
37.                 s = s & aa(j) & vbCrLf
    
38.             Next
    
39.         Else
    
40.             s = tt(ii)
    
41.         End If
    
42.         nm1 = pa1 & " 共" & UBound(aa) + 1 & "单.txt"
    
43.         Open nm1 For Output As #1
    
44.         Print #1, s
    
45.         Close (1)
    
46.     Next
    
47. Next
    
48. MsgBox "OK"
    
49. Application.ScreenUpdating = True
    
50. End Sub
    

复制代码

蓝桥玄霜

请见附件。

山菊花

yangjia1980 发表于 2016-2-16 16:35
追着山老师跑，嘿嘿
不如我这样请教您一下，
st.Cells(j, 2) = d1(bz1)

这个问题不好回答，我也不太清楚有什么会影响这个语句的效率。
生成字典与给单元格赋值不可比，哪个快哪个慢不说明什么。
生成字典好比是老师写出一个教案，赋值好比是给学生讲课，这两个过程哪个花时多也不是固定的。
通常，操作对象（比如给单元格赋值）比较费时，内存操作比较省时，好比写教案，有时就是一个念头一闪，教案就出来了。

yangjia1980

蓝桥玄霜 发表于 2016-2-16 16:39
请见附件。

蓝老师也来了啊，您能帮我看看这个帖子不？谢谢
http://club.excelhome.net/thread-1258960-1-1.html