将excel文件转化成特定格式文本文件

2014/11/14 37249
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
代码片段
