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

ykcbf1100 · 发表于 2024-4-30 10:56

本帖最后由 ykcbf1100 于 2024-4-30 11:03 编辑

参与一下。。。

Sub ykcbf() '//2024.4.30
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook
p = ws.Path & ""
Set Sh = ws.Sheets("汇总表格")
bt = 1: col = 1
With Sh
r = .Cells(Rows.Count, col).End(3).Row
c = .UsedRange.Columns.Count
arr = .[a1].Resize(r, c)
End With
For i = bt + 1 To UBound(arr)
s = CStr(arr(i, col)): ss = Replace(arr(i, 2), "/", "-")
If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
d(s)(ss)(i) = Application.Index(arr, i)
Next
On Error Resume Next
For Each k In d.keys
Sh.Copy
Set wb = ActiveWorkbook
n = 0
For Each kk In d(k).keys
n = n + 1
m = d(k)(kk).Count
Set wb1 = Workbooks.Add
If n = 1 Then
Set sht = wb.Sheets(1)
Else
Sh.Copy After:=wb.Sheets(wb.Sheets.Count)
Set sht = wb.Sheets(wb.Sheets.Count)
End If
With sht
.Name = kk
.DrawingObjects.Delete
.UsedRange.Offset(bt + m).Clear
.Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k)(kk).Items, 1)
.Cells.Copy wb1.Sheets(1).[a1]
End With
With wb1
.Sheets(1).Name = kk
.SaveAs Filename:=p & Trim(.Sheets(1).Cells(2, 3)) & kk & ".TXT", FileFormat:=xlUnicodeText
.Close 1
End With
Next
wb.SaveAs p & k, 51
wb.Close 1
Next
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End Sub

复制代码

3190496160 · 发表于 2024-4-30 10:57

jerry83 发表于 2024-4-30 10:42
老师不好意思，我需要导出的是D列“版型”数据，请问如何修改

3190496160 · 发表于 2024-4-30 10:59

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

jerry83 · 发表于 2024-4-30 12:21

ykcbf1100 发表于 2024-4-30 10:55
代码更新一下，附件供参考。。。

老师，我这边是需要只导出第四列的数据，如何修改

ykcbf1100 · 发表于 2024-4-30 12:29

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

你D列数据都一样的，导出去有何意义呢？

jerry83 · 发表于 2024-4-30 12:37

ykcbf1100 发表于 2024-4-30 12:29
你D列数据都一样的，导出去有何意义呢？

老师，这个只是一个举例，实际数据是存在不同的。每个筛选的数据从第二行第四列开始

ykcbf1100 · 发表于 2024-4-30 12:39

jerry83 发表于 2024-4-30 12:37
老师，这个只是一个举例，实际数据是存在不同的。每个筛选的数据从第二行第四列开始

你上传一个TXT文件的结果表上来参考一下，现在这样容易浪费时间。

jerry83 · 发表于 2024-4-30 13:47

ykcbf1100 发表于 2024-4-30 12:39
你上传一个TXT文件的结果表上来参考一下，现在这样容易浪费时间。

老师，麻烦看下附件

limonet · 发表于 2024-4-30 14:23

关键字：Into

limonet · 发表于 2024-4-30 14:24

Sub limonet()
Dim Cn As Object, StrSQL$, Arr As Variant, i%, j%, Brr As Variant, intNum%
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 商品编码,采购日期,First(Replace(商品名称,' ','')) From [汇总表格$] Group By 商品编码,采购日期").GetRows
ReDim Preserve Arr(0 To 2, 0 To UBound(Arr, 2) + 1)
For i = UBound(Arr, 2) - 1 To 0 Step -1
      If i = UBound(Arr, 2) - 1 Or Arr(0, i) <> Arr(0, i + 1) Then
         Cn.Close: Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.Path & "\" & Arr(0, i) & ".xlsx"
      End If
      StrSQL = "Select * Into [" & Arr(1, i) & "] From [Excel 12.0;DataBase=" & ThisWorkbook.FullName & "].[汇总表格$] Where 商品编码=" & Arr(0, i) & " And 采购日期=#" & Arr(1, i) & "#"
      Cn.Execute (StrSQL): Brr = Cn.Execute(Replace(StrSQL, "Into [" & Arr(1, i) & "]", "")).GetRows(, , "版型")
      intNum = FreeFile
      Open ThisWorkbook.Path & "\" & Arr(2, i) & Arr(1, i) & ".txt" For Output As #intNum
      For j = 0 To UBound(Brr, 2)
         Write #intNum, Brr(0, j)
      Next j
      Close intNum
Next i
End Sub

		自动登录	找回密码
密码			免费注册

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

最新热点 /1