求助，文本内容汇总到EXCEL里

菊子红了

求助，我想把多个文本文件内容汇总到EXCEL里。A列文本内容里的零件名，B列文本文件名称，D列开始文本里的MAX,MIN值，依次向右排。

醉眼看尘世

1. Sub 读取write写入的文本()
   
2.     Dim mFile$, tmPstr$, reGxp As Object, Str1$, tmPobj As Object, LJstr$, sH As Worksheet, tmProw%
   
3.     Set sH = ActiveSheet
   
4.     sH.UsedRange.ClearContents
   
5.     tmProw = 0
   
6.     Set reGxp = CreateObject("vbScript.regExp")
   
7.     reGxp.Global = True
   
8.     reGxp.Pattern = "(\-?\d+(\.\d+)?\s+){4}(\-?\d+(\.\d+)?)\s+(\-?\d+(\.\d+)?)"
   
9.     mFile = Dir(ThisWorkbook.Path & "\*.txt")
   
10.     Do While mFile <> ""
    
11.         Open ThisWorkbook.Path & "" & mFile For Input As #1
    
12.             Str1 = ""
    
13.             Do While Not EOF(1)
    
14.                 Line Input #1, tmPstr
    
15.                 If InStr(tmPstr, "零件名: ") Then LJstr = Right(tmPstr, Len(tmPstr) - 4): Str1 = LJstr & Chr(10) & mFile
    
16.                 If reGxp.test(tmPstr) Then
    
17.                     Set tmPobj = reGxp.Execute(tmPstr)
    
18.                     Str1 = Str1 & Chr(10) & tmPobj(0).submatches(2) & Chr(10) & tmPobj(0).submatches(4)
    
19.                 End If
    
20.             Loop
    
21.             Close #1
    
22.             Trr = Split(Str1, Chr(10))
    
23.             tmProw = tmProw + 1
    
24.             sH.Cells(tmProw, 1).Resize(1, UBound(Trr) + 1) = Trr 'Application.WorksheetFunction.Transpose(Trr)
    
25.      mFile = Dir
    
26.      Loop
    
27.      MsgBox "Done!"
    
28. End Sub

复制代码

菊子红了

醉眼看尘世 发表于 2024-8-8 14:48

谢谢，汇总成功了。向大神学习！

3190496160

Sub 提取数据()
Application.ScreenUpdating = False
Dim ar As Variant
Dim arr()
Set sh = ThisWorkbook.ActiveSheet
ReDim arr(1 To 90000, 1 To 200)
f = Dir(ThisWorkbook.Path & "\*.txt")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Open ThisWorkbook.Path & "\" & f For Input As #1 ''打开选择的文本文件
        n = n + 1
        ar = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) ''把文本文件的数据赋值给数组lines
        k = UBound(ar) ' + 1 '文件的行数
        '遍历每一行
        y = 3
        arr(n, 1) = Replace(ar(3), "零件名: ", "")
        arr(n, 2) = Replace(f, ".TXT", "")
        For i = 9 To k ''循环数组行
            If Left(ar(i), 1) <> "" Then
                If InStr(ar(i), "MIN") = 0 Then
                    rr = Split(ar(i), Chr(32))
                    m = 0
                    ReDim br(1 To UBound(rr) + 1)
                    For s = 0 To UBound(rr)
                        If rr(s) <> "" Then
                            If IsNumeric(rr(s)) Then
                                m = m + 1
                                br(m) = rr(s)
                            End If
                        End If
                    Next s
                    If m > 1 Then
                        y = y + 2
                        arr(n, y - 1) = br(m - 1)
                        arr(n, y) = br(m)
                    End If
                End If
            End If
        Next i
        Close #1 ''关闭打开的文本文件
    End If
f = Dir
Loop
With sh
    .[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
    .[a1].CurrentRegion.Offset(2) = Empty
    .[a3].Resize(n, 39) = arr
    .[a3].Resize(n, 39).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

002.rar (22.21 KB, 下载次数: 7)

2024-8-8 15:19 上传

点击文件名下载附件

菊子红了

醉眼看尘世 发表于 2024-8-8 14:48

这样汇总出来的数值是文本格式，能转成数字格式吗？

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()              '//2024.8.8
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 1000, 1 To 100)
   
7.     On Error Resume Next
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase$(f.Name) Like "*.txt" Then
   
10.             fn = fso.GetBaseName(f)
    
11.             m = m + 1
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             With wb.Sheets(1)
    
14.                 arr = .UsedRange
    
15.                 wb.Close False
    
16.             End With
    
17.             c = 3
    
18.             For i = 2 To UBound(arr) - 1
    
19.                 If InStr(arr(i, 1), "零件") Then brr(m, 1) = Split(arr(i, 1), ":")(1)
    
20.                 brr(m, 2) = f.Name
    
21.                 If InStr(arr(i, 1), "MAX") And InStr(arr(i + 1, 1), "DIM") = 0 Then
    
22.                     st = WorksheetFunction.Trim(arr(i + 1, 1))
    
23.                     st = Split(st)
    
24.                     If st(5) <> Empty Then
    
25.                         c = c + 1
    
26.                         brr(m, c) = st(5)
    
27.                         c = c + 1
    
28.                         brr(m, c) = st(6)
    
29.                     End If
    
30.                 End If
    
31.             Next
    
32.             Max = IIf(Max < c, c, Max)
    
33.         End If
    
34.     Next f
    
35.     With sh
    
36.         .UsedRange.Offset(2) = ""
    
37.         .[a3].Resize(m, Max) = brr
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    
42. 
    

复制代码

菊子红了

3190496160 发表于 2024-8-8 15:19

非常赞，格式也整理的很漂亮

醉眼看尘世

菊子红了 发表于 2024-8-8 15:29
这样汇总出来的数值是文本格式，能转成数字格式吗？

设置格式为常规，全部乘1就行了