提取多个TXT的指定内容放在EXCEL里

ykcbf1100

sampsonpon 发表于 2024-4-12 08:50
老师，能否再帮忙润一下以下四点要求。感谢！

改好了。。。

ykcbf1100

代码已更新。。。

1. Sub ykcbf()  '//2024.4.12
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 50000, 1 To 15)
   
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.             Set wb = Workbooks.Open(f, 0)
    
12.             With wb.Sheets(1)
    
13.                 zrr = .UsedRange
    
14.                 wb.Close
    
15.             End With
    
16.             For i = 5 To UBound(zrr)
    
17.                 st = WorksheetFunction.Trim(zrr(i, 1))
    
18.                 If InStr(zrr(i, 1), "|--") = 0 Then
    
19.                     b = Split(zrr(i, 1), "|")
    
20.                     If b(2) <> Empty And InStr(b(4), "TO Number") = 0 Then
    
21.                         m = m + 1
    
22.                         For x = 1 To 15
    
23.                             brr(m, x) = Trim(b(x))
    
24.                         Next
    
25.                     End If
    
26.                     st = Replace(brr(m, 9), ".", "-")
    
27.                     brr(m, 9) = IIf(Left(st, 2) = "00", "", Format(st, "yyyy/m/d"))
    
28.                     st = Replace(brr(m, 12), ".", "-")
    
29.                     brr(m, 12) = IIf(Left(st, 2) = "00", "", Format(st, "yyyy/m/d"))
    
30.                     brr(m, 13) = IIf(Left(CDate(brr(m, 13)), 2) = "0:", "", brr(m, 13))
    
31.                     brr(m, 14) = IIf(Left(CDate(brr(m, 14)), 2) = "0:", "", brr(m, 14))
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.     Next f
    
36.     With sh
    
37.         .UsedRange.Offset(1).Clear
    
38.         .Columns("a:g").NumberFormatLocal = "@"
    
39.         .Columns(8).NumberFormatLocal = "0"
    
40.         .[a2].Resize(m, 15) = brr
    
41.         .[a2].Resize(m, 15).Borders.LineStyle = 1
    
42.         .[a2].Resize(m, 15).Sort .[o2], 2
    
43.         r1 = .Cells(Rows.Count, 2).End(3).Row
    
44.         For i = r1 To 2 Step -1
    
45.             If .Cells(i, 2).Value <> Empty Then Exit For
    
46.             r = i - 1
    
47.         Next
    
48.         .UsedRange.Offset(r).Clear
    
49.     End With
    
50.     Application.ScreenUpdating = True
    
51. End Sub
    

复制代码

sampsonpon

ykcbf1100 发表于 2024-4-12 09:23
代码已更新。。。

很好！谢谢老师！
不过如果我事先设置好格式：如字体、居中，然后刷新数据后格式能保持不变就好了

ykcbf1100

sampsonpon 发表于 2024-4-12 11:08
很好！谢谢老师！
不过如果我事先设置好格式：如字体、居中，然后刷新数据后格式能保持不变就好了

这里的Clear改成ClearContents就可以了

sampsonpon

ykcbf1100 发表于 2024-4-12 11:12
这里的Clear改成ClearContents就可以了

改了，但是其中还是会有部分数据又变成新格式了，这是啥问题？

ykcbf1100

sampsonpon 发表于 2024-4-12 11:28
改了，但是其中还是会有部分数据又变成新格式了，这是啥问题？

那应该是你设置的格式行数太少了。

sampsonpon

ykcbf1100 发表于 2024-4-12 12:50
那应该是你设置的格式行数太少了。

NONONO,我是从上面整列设置格式的。

ykcbf1100

sampsonpon 发表于 2024-4-12 13:00
NONONO,我是从上面整列设置格式的。

上传附件。。。

sampsonpon

ykcbf1100 发表于 2024-4-12 13:07
上传附件。。。

大师，请看附件

ykcbf1100

sampsonpon 发表于 2024-4-12 13:36
大师，请看附件

改好了。。。

你只要设置好2~4行的格式就行了，其它行代码会自动复制下去。整列设置格式不好，容易让表臃肿。