Excel批量导入TXT数据问题

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

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

liwen

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

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

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