- Sub CreatetxtFile()
- Dim sFile As Object, fso As Object
- Dim str1 As String '处理每行内容
- 'Dim lx As String '数据类型
- Dim stt As String
- Dim sfile1 As String '文件位置
- Dim sfile2 As String '文件全名
- Dim tt As String '文件全名,不含扩展名
- Dim dt As String '生成的文本文件全名
- Dim fs '待写数据
- Dim r As Integer '最大行数
- Dim c As Integer '最大列数
- Dim i As Integer '行
- Dim j As Integer '列
- Dim sl As Integer '要求的长度
- Dim scl As Integer '当前长度
- 'Dim shuz As Double '数值类型
- r = Sheet1.UsedRange.Rows.Count '最大行数
- c = Sheet1.UsedRange.Columns.Count '最大列数
- sfile1 = ThisWorkbook.Path '当前工作簿路径
- sfile2 = ThisWorkbook.FullName '当前工作簿全名
- tt = Mid(sfile2, 1, InStrRev(sfile2, ".") - 1) '当前工作簿全名,不包含扩展名
- dt = tt & ".txt" '生成的文本文件全名
- Set fso = CreateObject("Scripting.FileSystemObject")
- Set sFile = fso.createTextFile(dt, True, False) '在当前工作薄位置生成同名文本文件
- 'Open dt For Output As #1: Close #1 '打开处理文件,以二进制方式写入
- 'Open dt For Binary Access Write As #1
- For i = 1 To r
- str1 = ""
- For j = 1 To c
- '将每一格单元格格式化后再合并作一行,准备写入文本文件
- stt = Trim(Sheet1.Cells(i, j)) '单元格内容
- lx = Trim(Sheet2.Cells(2, j + 1)) '单元格数据类型
- sl = Val(Sheet2.Cells(3, j + 1)) '单元格要求的长度
- scl = LenB(StrConv(stt, vbFromUnicode)) '汉字按双字节,统一编码后再计算
- '格式化单元格内容
- If scl <= sl Then
- stt = stt & Space(sl - scl) '如果长度不足就用空格补齐 String(sl - scl, "A") 用字符"A"补齐
- Else
- stt = Left(stt, sl / 2) '如果长度过长则从左端起取规定长度一半的字符串,汉字按双字节,此处处理方法可以改进!!!!
- stt = stt & Space(sl - LenB(StrConv(stt, vbFromUnicode))) '截取过后不足规定长度的补齐空格
- End If
- str1 = str1 & stt
- Next j
- sFile.writeLine (str1) '一行数据结束换行
- 'Put #1, , str1 & strCrLf '二进制模式时写入一行数据结束换行
- Next i
- Close #1
- Set sFile = Nothing
- Set fso = Nothing
- End Sub
来源: http://www.phpxs.com/code/1008759/