系统提出来的txt文件能导入到表格里吗

sun4400

“整理”表格是想要的最终效果，里面的姓名、标题、文字来源于“导出”表格里对应的内容，”简介“来源于对应文件名的txt文件里的文本内容。
万分感谢！！！！！！！！！！！！！！！！！！
原始.rar (21.75 KB, 下载次数: 11)

2023-2-5 16:33 上传

点击文件名下载附件

3190496160

上传你的附件也许会有办法解决，没有附件肯定是么有办法的

sun4400

收到，感谢

3190496160

Sub 整理数据()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim d As Object
Dim objStream, strData
Set d = CreateObject("scripting.dictionary")
f = Dir(ThisWorkbook.Path & "\导出.xls*")
If f = "" Then MsgBox "找不到导出文件！": End
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
With wb.Worksheets(1)
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:a" & rs)
End With
wb.Close False
Dim arr()
ReDim arr(1 To UBound(ar), 1 To 7)
For i = 1 To UBound(ar) Step 5
    If Trim(ar(i, 1)) <> "" Then
        n = n + 1
        arr(n, 1) = n
        arr(n, 2) = "集团内"
        arr(n, 3) = ar(i + 1, 1)
        arr(n, 4) = ar(i, 1)
        arr(n, 5) = Split(ar(i + 4, 1), ".")(0)
        d(arr(n, 5)) = n
    End If
Next i
Set f = Nothing
f = Dir(ThisWorkbook.Path & "\*.txt")
Do While f <> ""
    Set objStream = CreateObject("ADODB.Stream")
    objStream.Charset = "utf-8"
    objStream.Open
    objStream.LoadFromFile (ThisWorkbook.Path & "\" & f)
    strData = objStream.ReadText()
    s = strData
    mc = Split(f, ".")(0)
    objStream.Close
    Set objStream = Nothing
    xh = d(mc)
    If xh <> "" Then
        arr(xh, 5) = s
    End If
f = Dir
Loop
rs = Cells(Rows.Count, 7).End(xlUp).Row
If rs > 1 Then Range("f2:l" & rs) = Empty
[f2].Resize(n, UBound(arr, 2)) = arr
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

mmwwdd

3190496160 发表于 2023-2-6 13:13
Sub 整理数据()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

好,厉害,还有解说

sun4400

超级厉害，就是敬佩！！！！万分感谢！

gwjkkkkk

参与一下。。。