Question

请问如何利用VBA将Excel表格内容按照要求分割为若干txt文件？

现在需要按照班级（A列）生成3个txt文件，txt文件以空格或者制表符作为分隔符。
txt文件以班级命名（例如2班的命名为 2.txt），txt文件中第一列为学号、第二列至第四列为科目及成绩。
以2班为例，生成文件如下:

谢谢各位，期待您的解决方案。





Answer 1

我的思路是先用代码里做筛选，再把筛选结果写入txt文件。给你一段代码试试
Sub 筛选后输出到文本()
Application.ScreenUpdating = False
Dim clas As Variant
Dim iRow%, iPath$, iFileName$, filReg As Range
Dim fso As Object, sfile As Object
clas = Array(1, 2, 3)
iPath = ThisWorkbook.Path

Columns("P:T").Clear
Columns("F:G").Clear
If ActiveSheet.AutoFilterMode = True Then Range("a1").CurrentRegion.AutoFilter
Range("a1").CurrentRegion.Sort key1:=Range("a1"), key2:=Range("b1"), Order2:=xlAscending, Header:=xlGuess
For I = 0 To UBound(clas)
With ActiveSheet.Range("a1")
Range("G1") = "班级": Range("G2") = clas(I)
.CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("g1:g2"), _
copytorange:=Range("p1")
Set filReg = Range("p1").CurrentRegion
iFileName = iPath & "\" & clas(I) & "班成绩.txt"
Set fso = CreateObject("scripting.filesystemobject")
If fso.fileexists(iFileName) Then fso.deletefile (iFileName)
Set sfile = fso.createtextfile(iFileName)
sfile.writeline (Application.Rept(" ", 10) & clas(I) & "班成绩表")
For j = 1 To filReg.Rows.Count
sfile.writeline (filReg.Cells(j, 2) & Chr$(9) & _
filReg.Cells(j, 3) & Chr$(9) & _
filReg.Cells(j, 4) & Chr$(9) & _
filReg.Cells(j, 5) & Chr$(9))
Next j
Columns("P:T").Clear
End With
Set fso = Nothing
Set sfile = Nothing
Next I
Columns("F:G").Clear
Application.ScreenUpdating = True
End Sub

追问

谢谢，我感觉网友“路十千”的更好一些。 当运行到 .CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("g1:g2"), _
copytorange:=Range("p1")
时提示错误，不知道什么原因。

Answer 2

可以扩展多科的：
Sub test()
Dim arr, i%, j%, tmp$
Set d = CreateObject("Scripting.Dictionary")
arr = ActiveSheet.[a1].CurrentRegion
For i = 2 To UBound(arr)
tmp = ""
If d.exists(arr(i, 1)) = False Then
d(arr(i, 1)) = arr(1, 2)
For j = 3 To UBound(arr, 2)
d(arr(i, 1)) = d(arr(i, 1)) & vbTab & arr(1, j)
Next
End If
For j = 2 To UBound(arr, 2)
If tmp = "" Then tmp = arr(i, j) Else tmp = tmp & vbTab & arr(i, j)
Next
d(arr(i, 1)) = d(arr(i, 1)) & vbCrLf & tmp
Next
a = d.keys: b = d.Items
For i = 0 To d.Count - 1
Open ThisWorkbook.Path & "\" & a(i) & ".txt" For Output As #1
Print #1, b(i)
Close #1
Next
MsgBox "已完成，生成文件在本文件同目录下。"
End Sub

Answer 3

其实就是一个拆分代码

追问

我是新手，麻烦您给一段代码啊，谢谢。