Excel批量导入TXT数据问题

dostpy

请问：现在我有近千个TXT文本数据，0001.txt~0999.txt，每一个都需要单独导入新的Excel工作表，数据——导入外部数据——导入数据，然后设置一些，完成之后，另存为0001.xls~0999.xls。

每一个的过程虽然很简单都一模一样，但是我现在有近千个，那还不累死人啦？！请问有什么批处理的方法吗？用宏可以吗？如果可以的话请看下面我录制的语句，需要修改什么地方？！据说把路径文件名改成变量就行了？怎样修改，谢谢！

Sub Macro1()
'
' Macro1 Macro
' 宏由 User 录制，时间: 2008-8-21
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\xxx\0001.txt" _
        , Destination:=Range("A1"))
        .Name = "AIDC-0121"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 936
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "|"
        .TextFileColumnDataTypes = Array(2, 1, 2, 1, 1, 1, 1, 1, 1, 2, 9)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    ActiveWorkbook.SaveAs Filename:= _
        "D:\xxx\0001.xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
End Sub

liwen

Sub Macro1()
on error resume next
'未作测试
For i=1 to 999
filename=format(i,"0000")
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\xxx\" & filename & ".txt" _
        , Destination:=Range("A1"))
        .Name = "AIDC-0121"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 936
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "|"
        .TextFileColumnDataTypes = Array(2, 1, 2, 1, 1, 1, 1, 1, 1, 2, 9)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    ActiveWorkbook.SaveAs Filename:= _
        "D:\xxx\" & filename & "..xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
next
End Sub

ycxchen

For i=1 to 999换成For i=0 to 999  行吗？

liwen

Sub test()
On Error Resume Next
Set fs = Application.FileSearch
With fs
    .LookIn = ThisWorkbook.Path
    .Filename = "*.txt"
    If .Execute > 0 Then
       If MsgBox("本文件夹下有" & .FoundFiles.Count & " 文件需要导入，确认导入吗?", vbYesNo, "导入确认") = vbNo Then Exit Sub
        For i = 1 To .FoundFiles.Count
            filenameStr = Mid(Left(.FoundFiles(i), Len(.FoundFiles(i)) - 4), Len(ThisWorkbook.Path) + 2)
            
         Workbooks.Add
      
                With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & ThisWorkbook.Path & "\" & filenameStr & ".txt", Destination:= _
        Range("A1"))
        .Name = filenameStr
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 936
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "|"
        .TextFileColumnDataTypes = Array(2, 1, 2, 1, 1, 1, 1, 1, 1, 2, 9)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
   
         ChDir ThisWorkbook.Path
          ActiveWorkbook.SaveAs Filename:= _
         ThisWorkbook.Path & "\" & filenameStr & ".xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
    ActiveWindow.Close
      
            
        Next i
    Else
        MsgBox "没有需要导入的文件"
    End If
End With
End Sub

dostpy

版主老大，弱弱的问一下，在哪里设置文件的导入路径啊？怎么导入？？[:30]

dostpy

老大，好像因为那句ThisWorkbook.Path 所以必须先在需要转换的目录打开或新建一个工作簿，然后才可以吧。。。我是这样才行的

请问，可以把那句ThisWorkbook.Path 改成绝对路径吗？比如C:\xxxx

pureshadow

这个.....这个......
貌似可以直接用EXCEL打开TXT

liwen

原帖由 dostpy 于 2008-8-22 19:09 发表
老大，好像因为那句ThisWorkbook.Path 所以必须先在需要转换的目录打开或新建一个工作簿，然后才可以吧。。。我是这样才行的

请问，可以把那句ThisWorkbook.Path 改成绝对路径吗？比如C:\xxxx

实践是检验真理的唯一标准，自己动手替换试试就知道了。

dostpy

版主这段程序写得很好啊，有很多值得我这个新手回味、学习的地方，谢谢liwen版主不仅 授人以鱼，而且最重要的是授人以渔！太感谢了！

dostpy

liwen版主,你真是太帅了！！！刚才用你这段程序修改了一下，又搞定一个类似的任务，再一次衷心感谢！！[:50]