如何将excel工作薄按照条件分割成工作表，同时导出为txt文档

jerry83

limonet 发表于 2024-4-30 14:23
关键字：Into

老师，请问提示路径没有找到是什么原因
Open ThisWorkbook.Path & "\" & Arr(2, i) & Arr(1, i) & ".txt" For Output As #intNum

limonet

jerry83 发表于 2024-4-30 14:27
老师，请问提示路径没有找到是什么原因
Open ThisWorkbook.Path & "\" & Arr(2, i) & Arr(1, i) & ".txt ...

你在立即窗口输入并回车看一下。
?ThisWorkbook.Path & "\" & Arr(2, i) & Arr(1, i) & ".txt"

ykcbf1100

jerry83 发表于 2024-4-30 13:47
老师，麻烦看下附件

只需要保存TXT文件吗？

ykcbf1100

jerry83 发表于 2024-4-30 12:21
老师，我这边是需要只导出第四列的数据，如何修改

你试一下，看是不是你想要的。

ykcbf1100

按楼主要求改了一下。

1. Sub ykcbf()   '//2024.4.30
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set ws = ThisWorkbook
   
6.     p = ws.Path & ""
   
7.     Set Sh = ws.Sheets("汇总表格")
   
8.     bt = 1: col = 1
   
9.     With Sh
   
10.         r = .Cells(Rows.Count, col).End(3).Row
    
11.         c = .UsedRange.Columns.Count
    
12.         arr = .[a1].Resize(r, c)
    
13.     End With
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = CStr(arr(i, col)): ss = Replace(arr(i, 2), "/", "-")
    
16.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
17.         If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
    
18.         d(s)(ss)(i) = Application.Index(arr, i)
    
19.     Next
    
20.     On Error Resume Next
    
21.     For Each k In d.keys
    
22.         Sh.Copy
    
23.         Set wb = ActiveWorkbook
    
24.         n = 0
    
25.         For Each kk In d(k).keys
    
26.             n = n + 1
    
27.             m = d(k)(kk).Count
    
28.             Set wb1 = Workbooks.Add
    
29.             If n = 1 Then
    
30.                 Set sht = wb.Sheets(1)
    
31.             Else
    
32.                 Sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    
33.                 Set sht = wb.Sheets(wb.Sheets.Count)
    
34.             End If
    
35.             With sht
    
36.                 .Name = kk
    
37.                 .DrawingObjects.Delete
    
38.                 .UsedRange.Offset(bt + m).Clear
    
39.                 .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k)(kk).Items, 1)
    
40.                 .Cells.Copy wb1.Sheets(1).[a1]
    
41.             End With
    
42.             With wb1
    
43.                 .Sheets(1).Name = kk
    
44.                 fn1 = Trim(.Sheets(1).Cells(2, 3))
    
45.                 .Sheets(1).Columns(5).Delete
    
46.                 .Sheets(1).Range("A:C").Delete
    
47.                 .SaveAs Filename:=p & Format(kk, "yyyy年m月d日-") & fn1 & ".TXT", FileFormat:=xlUnicodeText
    
48.                 .Close 1
    
49.             End With
    
50.         Next
    
51.         wb.SaveAs p & k, 51
    
52.         wb.Close 1
    
53.     Next
    
54.     Set d = Nothing
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "拆分完毕！"
    
57. End Sub
    

复制代码