前言:同事有个上传文件的需求,要求格式为utf-8格式的txt文件,vba里有个大神写的拆分宏很好用,我在网上又找了写入utf-8 txt文件的办法,组合了一下,就成了以下代码,试验了一下可以拆分
Sub 拆分()
Dim path As String
'获取字典
Set d = CreateObject("scripting.dictionary")
'获取当前待处理的工作表名称
sheet_name = ActiveSheet.Name
'输入获取拆分需要的条件列
Dim col_name
col_name = Application.InputBox("请输入拆分依据的列号(如A):")
'输入拆分的开始行,要求输入的是数字(我这边注释掉了,因为一般都是从第二行开始拆分)
'Dim start_row As Integer
'start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)
start_row = 2
'暂停屏幕更新
Application.ScreenUpdating = False
'工作表的总行数
Dim end_row
end_row = Worksheets(sheet_name).Range("A1048576").End(xlUp).Row
'把同类的所有行放入字典的item,类似于",2:2,3:3,5:5"这种
For i = start_row To end_row
d(Worksheets(sheet_name).Cells(i, col_name).Value) = _
d(Worksheets(sheet_name).Cells(i, col_name).Value) & "," & i
Next
'创建存放拆分表格的文件夹
On Error Resume Next
VBA.MkDir ThisWorkbook.path & "\拆分数据"
'遍历字典的Key,key值即为拆分的一个类别,key对应的item为该类别所在的行,复制这些行到新表,新表的名称为这个类别
Dim columnmax As Integer
columnmax = Worksheets(sheet_name).UsedRange.Columns.Count
For Each k In d.keys
arr = VBA.Split(d(k), ",")
wb_name = ThisWorkbook.path & "\拆分数据\" & k & ".txt"
'这边就是txt的创建和写入
Set adodbStream = CreateObject("ADODB.Stream")
With adodbStream
.Type = 2
.Charset = "UTF-8"
.Open
'这里是写入第一列的标题,vbTab是制表符,vbCrLf是换行符
For i = 1 To columnmax
.WriteText ThisWorkbook.Sheets(sheet_name).Cells(1, i).Value & vbTab
Next
.WriteText vbCrLf
'这边加了一个如果ar是空则跳到a(也就是next)的步骤,因为原代码中ar第一个有可能是空,导致出来的结果可能会有0 0 0 0 0这样的行
For Each ar In arr
If ar = "" Then GoTo a
For j = 1 To columnmax
temp = ThisWorkbook.Sheets(sheet_name).Cells(ar, j).Value
.WriteText temp & vbTab
Next
.WriteText vbCrLf
a:
Next
.SaveToFile wb_name, 2
End With
Next
'进行屏幕更新
Application.ScreenUpdating = True
MsgBox "拆分工作表完成,拆分好的数据在\拆分数据\文件夹下"
End Sub