将带分隔符txt文件另存为xls格式

 

'功能：批量另存为一个目录下的XLS文件
'srcPath 源目录
'desPath 目标目录
'---------------------------------------
Sub SaveAsExcelInPath(srcPath As String, desPath As String)
    If Right(srcPath, 1) <> "\" Then
        srcPath = srcPath + "\"
    End If
    If Right(desPath, 1) <> "\" Then
        desPath = desPath + "\"
    End If
   
    ChDir srcPath
    Dim f_name$
    f_name = Dir(srcPath + "*.xls")       
    While f_name <> ""
        SaveAsExcel srcPath, desPath, f_name
        f_name = Dir()
    Wend
End Sub

'---------------------------------------
'功能：另存为一个XLS文件
'srcPath 源目录
'desPath 目标目录
'FileName 文件名
'---------------------------------------
Sub SaveAsExcel(srcPath As String, desPath As String, FileName As String)
    If Right(srcPath, 1) <> "\" Then
        srcPath = srcPath + "\"
    End If
    If Right(desPath, 1) <> "\" Then
        desPath = desPath + "\"
    End If
   
    ChDir srcPath
        Workbooks.OpenText FileName:= _
            srcPath + FileName, _
            Origin:=936, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
            xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
            Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
            Array(2, 1)), TrailingMinusNumbers:=True
        ChDir desPath
        ActiveWorkbook.SaveAs FileName:= _
            desPath + FileName, FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
        ActiveWindow.Close
End Sub

'调用将c:\下的txt另存为c:\xls目录下，并转换为xls格式

SaveAsExcelInPath "C:\", _
        "C:\xls"

发表于 @ 2007年08月28日　14:10:00 | 评论( loading... ) | 编辑| 举报| 收藏

旧一篇:双链表 | 新一篇:xls批量导入sql server