求将TXT文件的内容导入EXCEL的方法

lovelfg

现有一个EXCEL,同路径下有一个叫DATA的文件夹，里面包含若干个TXT文档，TXT文档数量并不固定，现想将所有TXT文档里的内容导入至EXCEL中，并且每个文档导入不同的sheet，每个sheet命名为TXT文件名的最后一段（以下划线区分），附件模拟了结果，求教VBA代码应该如果写呢？

mytto88

Sub kk()
    Dim fso As Object, txt As Object
    Dim strPath As String, f As Object, arr_data(1 To 65536, 1 To 1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path & "\Data"
    For Each f In fso.GetFolder(strPath).Files
        ex_name = fso.GetExtensionName(f)
        n = 0
        Erase arr_data
        If ex_name = "txt" Then
            sht_name = Split(fso.GetBaseName(f), "_")(4)
            Set txt = fso.OpenTextFile(f, ForReading)
            Do While txt.AtEndOfStream = False
                n = n + 1
                arr_data(n, 1) = txt.ReadLine
            Loop
            On Error Resume Next
            Set sht = Worksheets(sht_name)
            sht.Cells.Clear
            sht.Range("a1").Resize(n, 1) = arr_data
             If Err.Number <> 0 Then
                Set sht = Worksheets.Add(, Worksheets(Worksheets.Count))
                sht.Name = sht_name
                sht.Range("a1").Resize(n, 1) = arr_data
                Err.Clear
             End If
        End If
    Next
    Set fos = Nothing
   
End Sub