将多个txt文件拉入现有的excel工作簿,根据文本文件名将文本文件组织到Excel中

new9mtju  于 12个月前  发布在  其他
关注(0)|答案(1)|浏览(92)

下面是我发现的将文本文件拉入excel并根据文本文件名将每个文本文件导入现有工作表的代码。
图片来源:https://stackoverflow.com/a/41755181

Sub ImportTXTFiles()
        Dim fso As Object
        Dim xlsheet As Worksheet
        Dim qt As QueryTable
        Dim txtfilesToOpen As Variant, txtfile As Variant

        Application.ScreenUpdating = False
        Set fso = CreateObject("Scripting.FileSystemObject")

        txtfilesToOpen = Application.GetOpenFilename _
                     (FileFilter:="Text Files (*.txt), *.txt", _
                      MultiSelect:=True, Title:="Text Files to Open")

        For Each txtfile In txtfilesToOpen
            ' FINDS EXISTING WORKSHEET
            For Each xlsheet In ThisWorkbook.Worksheets
                If xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "") Then
                    xlsheet.Activate
                    GoTo ImportData
                End If
            Next xlsheet

      
            ' IMPORT DATA FROM TEXT FILE
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & txtfile, _
              Destination:=ActiveSheet.Cells(1, 1))
                .TextFileParseType = xlDelimited
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = False
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
                .TextFileOtherDelimiter = "|"

                .Refresh BackgroundQuery:=False
            End With

            For Each qt In ActiveSheet.QueryTables
                qt.Delete
            Next qt
        Next txtfile

        Application.ScreenUpdating = True
        MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"

        Set fso = Nothing
    End Sub

字符串
我唯一的问题是,这段代码替换了工作表中已经存在的数据。我希望能够继续拉入数据,并根据文本文件名将其“导入”到相应工作表中的下一个可用行。

x6yk4ghg

x6yk4ghg1#

  • End定位最后一个数据行。
  • 增加空白单的特殊处理代码。
  • GoTo ImportData在你的代码中,但没有行号ImportData
  • 我建议避免使用GoTo
Option Explicit

Sub ImportTXTFiles()
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim txtfilesToOpen As Variant, txtfile As Variant
    
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    txtfilesToOpen = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt", MultiSelect:=True, Title:="Text Files to Open")
    
    Dim oSht As Worksheet, sShtName As String
    For Each txtfile In txtfilesToOpen
        ' FINDS EXISTING WORKSHEET
        Set oSht = Nothing
        sShtName = Replace(fso.GetFileName(txtfile), ".txt", "")
        For Each xlsheet In ThisWorkbook.Worksheets
            If xlsheet.Name = sShtName Then
                Set oSht = xlsheet
            End If
        Next xlsheet
        If oSht Is Nothing Then
            MsgBox "Can't find sheet " & sShtName
        Else
            ' IMPORT DATA FROM TEXT FILE
            Dim c As Range
            With oSht
                Set c = .Cells(.Rows.Count, 1).End(xlUp).Row
                If c.Row > 1 Then
                    Set c = c.Offset(1, 0)
                ElseIf Len(c.Value) = 0 Then
                    Set c = c.Offset(1, 0)
                End If
            End If
            With oSht.QueryTables.Add(Connection:="TEXT;" & txtfile, Destination:=c)
                .TextFileParseType = xlDelimited
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = False
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
                .TextFileOtherDelimiter = "|"
                
                .Refresh BackgroundQuery:=False
            End With
            
            For Each qt In oSht.QueryTables
                qt.Delete
            Next qt
        End If
    Next txtfile
    
    Application.ScreenUpdating = True
    MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"
    
    Set fso = Nothing
End Sub

字符串

  • Microsoft文档:*

Range.End property (Excel)

相关问题