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

jerry83

各位老师好，附件是需要处理的excel表格，我的需求如下，烦请各位老师帮忙解答，谢谢！
（一）按照A列中的“商品编号”分别导出为对应的工作表（工作表名称为“商品编号”）
（二）每个工作表按照“采购日期”生成对应的sheet页（sheet名称为“采购日期”）
（三）对应的sheet页的D列“版型”分别导出为txt文档，文档重命名为：商品名称-采购日期

liulang0808

（一）按照A列中的“商品编号”分别导出为对应的工作表（工作表名称为“商品编号”）
楼主这里的工作表是指工作簿，即excel文件吗？

导出具体文本格式，可以提供下，因为可以直接处理导出，不用经过中间步骤的

jerry83

liulang0808 发表于 2024-4-30 09:31
（一）按照A列中的“商品编号”分别导出为对应的工作表（工作表名称为“商品编号”）
楼主这里的工作表是 ...

是的，直接导出为记事本格式

baofa2

1. Sub test1()
   
2.   Dim ar, data, rowHeights() As Double, dict As Object
   
3.   Dim i As Long, j As Long, x As Long, vKey As Variant
   
4.   Dim dstFolder As String, wb As String, ws As String
   
5.   Dim titleRow As Long, wbCol As Long, wsCol As Long
   
6. 
   
7.   DoApp False
   
8. 
   
9.   titleRow = 1
   
10.   wbCol = 1
    
11.   wsCol = 2
    
12. 
    
13.   ReDim rowHeights(1 To titleRow + 1)
    
14. 
    
15.   dstFolder = ThisWorkbook.Path & "\分簿分表"
    
16.   If Dir(dstFolder, vbDirectory) = "" Then MkDir dstFolder
    
17. 
    
18.   Set dict = CreateObject("Scripting.Dictionary")
    
19.   With ActiveSheet
    
20.     data = .Range("A1").CurrentRegion.Value
    
21.     j = UBound(data, 2)
    
22.     For i = titleRow + 1 To UBound(data)
    
23.       wb = data(i, wbCol)
    
24.       ws = Format(data(i, wsCol), "yyyy-m-d")
    
25.       If Not dict.Exists(wb) Then Set dict(wb) = CreateObject("Scripting.DictionAry")
    
26.       If Not dict(wb).Exists(ws) Then Set dict(wb)(ws) = .Range("A1").Resize(titleRow, j)
    
27.       Set dict(wb)(ws) = Union(dict(wb)(ws), .Range("A" & i).Resize(, j))
    
28.     Next
    
29.     For j = 1 To UBound(data, 2)
    
30.       data(1, j) = .Columns(j).ColumnWidth
    
31.     Next
    
32.     For i = 1 To UBound(rowHeights)
    
33.       rowHeights(i) = .Rows(i).RowHeight
    
34.     Next
    
35.   End With
    
36. 
    
37.   For Each vKey In dict.Keys
    
38.     Application.SheetsInNewWorkbook = dict(vKey).Count
    
39.     With Workbooks.Add
    
40.       For j = 0 To dict(vKey).Count - 1
    
41.         With .Worksheets(j + 1)
    
42.           dict(vKey).Items()(j).Copy .Range("A1")
    
43.           .Name = dict(vKey).Keys()(j)
    
44.           For i = 1 To UBound(data, 2)
    
45.             .Columns(i).ColumnWidth = data(1, i)
    
46.           Next
    
47.           For i = 1 To UBound(rowHeights) - 1
    
48.             .Rows(i).RowHeight = rowHeights(i)
    
49.           Next
    
50.           .Rows(i & ":" & .UsedRange.Rows.Count).RowHeight = rowHeights(i)
    
51.           .DrawingObjects.Delete
    
52.           ar = .UsedRange
    
53.           For i = 1 To UBound(ar)
    
54.             For x = 2 To UBound(ar, 2)
    
55.               ar(i, 1) = ar(i, 1) & "," & ar(i, x)
    
56.             Next
    
57.           Next
    
58.           ar = WorksheetFunction.Transpose(WorksheetFunction.Index(ar, 0, 1))
    
59.           Open dstFolder & "\" & vKey & "_" & .Name & ".txt" For Output As #8
    
60.           Print #8, Join(ar, vbCrLf)
    
61.           Close #8
    
62.         End With
    
63.       Next
    
64.       .SaveAs dstFolder & "\" & vKey, 51
    
65.       .Close
    
66.     End With
    
67.   Next
    
68. 
    
69.   With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
70.     .SetText ""
    
71.     .PutInClipboard
    
72.   End With
    
73. 
    
74.   Set dict = Nothing
    
75.   Application.SheetsInNewWorkbook = 1
    
76.   DoApp
    
77.   Beep
    
78. End Sub
    
79. 
    
80. Function DoApp(Optional b As Boolean = True)
    
81.   With Application
    
82.     .ScreenUpdating = b
    
83.     .DisplayAlerts = b
    
84.     .Calculation = -b * 30 - 4135
    
85.   End With
    
86. End Function

复制代码

3190496160

Sub 拆分为txt文档()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("汇总表格")
  r = .Cells(.Rows.Count, 1).End(xlUp).Row
  arr = .Range("a1:e" & r)
End With
For j = 1 To UBound(arr, 2)
    If j = 1 Then
        zf = arr(1, j)
    Else
        zf = zf & "   " & arr(1, j)
    End If
Next j
For i = 2 To UBound(arr)
    zd = Format(arr(i, 2), "yyyy年m月d日") & "-" & Trim(arr(i, 3))
  If Not d.exists(zd) Then
    d(zd) = zf & vbCrLf & arr(i, 1) & "   " & arr(i, 2) & "   " & Trim(arr(i, 3)) & "   " & arr(i, 4) & "   " & arr(i, 5)
  Else
    d(zd) = d(zd) & vbCrLf & arr(i, 1) & "   " & arr(i, 2) & "   " & Trim(arr(i, 3)) & "   " & arr(i, 4) & "   " & arr(i, 5)
  End If
Next
For Each aa In d.keys
  Open ThisWorkbook.Path & "\" & aa & ".txt" For Output As #1
  Print #1, d(aa)
  Close #1
Next
MsgBox "ok!"
End Sub

3190496160

案例表格xlsx.rar (16.93 KB, 下载次数: 12)

2024-4-30 10:19 上传

点击文件名下载附件

jerry83

3190496160 发表于 2024-4-30 10:19

老师不好意思，我需要导出的是D列“版型”数据，请问如何修改

limonet

关键字：into

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Cn.Execute("Select 商品编码,采购日期 From [汇总表格$] Group By 商品编码,采购日期").GetRows
    For i = 0 To UBound(Arr, 2)
        Cn.Close
        Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.Path & "\" & Arr(0, i) & ".xlsx"
        StrSQL = "Select * Into [" & Arr(1, i) & "] From [Excel 12.0;DataBase=" & ThisWorkbook.FullName & "].[汇总表格$] Where 商品编码=" & Arr(0, i) & " And 采购日期=#" & Arr(1, i) & "#"
        Cn.Execute (StrSQL)
    Next i
End Sub

ykcbf1100

代码更新一下，附件供参考。。。