用VBA数据分类问题

6763194

请教一个用VBA数据分类问题，具体情况见附件

gwjkkkkk

gwjkkkkk

请参考。。。

6763194

gwjkkkkk 发表于 2025-1-29 17:48
请参考。。。

谢谢了！这个正是我想要的，

西瓜籽

供参考

西瓜籽

附件补上

守候_CJ

参考代码

1. Sub 拆分数据到txt()
   
2.     Dim i As Long
   
3.     Dim s As String
   
4.     Dim p As String
   
5.     Dim arr
   
6.    
   
7.     i = 1
   
8.    
   
9.     With Sheet1
   
10.         Do While .Range("A" & i).Value <> ""
    
11.             s = .Range("A" & i).Value
    
12.             arr = Split(s, "/")
    
13.             p = ThisWorkbook.Path & "" & arr(1)
    
14.             
    
15.             Open p For Append As #1
    
16.                 Print #1, s
    
17.             Close #1
    
18.             
    
19.             i = i + 1
    
20.         Loop
    
21.     End With
    
22.    
    
23.     MsgBox "完成！"
    
24. End Sub

复制代码

二、效果

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2025.1.30
   
2.     Dim arr
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     arr = Sheets("Sheet1").Range("a1").CurrentRegion
   
7.     For i = 1 To UBound(arr)
   
8.         If arr(i, 1) <> Empty Then
   
9.             st = Split(arr(i, 1), "/")
   
10.             s = st(1)
    
11.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
12.             d(s)(i) = arr(i, 1)
    
13.         End If
    
14.     Next
    
15.     For Each k In d.keys
    
16.         f = p & k & ".txt"
    
17.         Open f For Output As #1
    
18.         For Each kk In d(k).keys
    
19.             st = d(k)(kk)
    
20.             Print #1, st
    
21.         Next
    
22.         Close #1
    
23.     Next
    
24.     Set d = Nothing
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    
28. 
    

复制代码

6763194

ykcbf1100 发表于 2025-1-30 21:42
参与一下。。。

讲的很详细，谢谢你！