同路径提取所有txt的指定一行记录，谢谢ykcbf1100和gwjkkkkk两位老师！

lhj323323

老师


上传的附件里的写好的语句
能从同路径提取1个txt的最后一笔记录

我想改成如下效果，请看图


老师如有空，请帮忙看看，先谢谢了。
新建.rar (1.52 MB, 下载次数: 9)

2024-2-7 12:30 上传

点击文件名下载附件

小花鹿

论坛里有遍历文件夹内文件名的代码，套上就行，就是一个Do循环：
filename=dir(thisworkbook.path & "\*.txt")
Do While filenmae<>""
     对文本文件操作的代码
     filename=dir
Loop

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.7
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     On Error Resume Next
   
7.     ReDim brr(1 To 10000, 1 To 9)
   
8.     For Each f In Fso.GetFolder(p).Files
   
9.         If 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.                 dm = Split(arr(1, 1))(0)
    
16.                 wb.Close False
    
17.             End With
    
18.             For i = 3 To UBound(arr) - 1
    
19.                 If i = 3 Then
    
20.                     latestDate = CLng(arr(i, 1))
    
21.                 Else
    
22.                     If CLng(arr(i, 1)) > latestDate Then
    
23.                         latestDate = CLng(arr(i, 1))
    
24.                     End If
    
25.                 End If
    
26.             Next
    
27.             rq = CDate(latestDate)
    
28.             n = 0
    
29.             For i = 3 To UBound(arr) - 1
    
30.                 If arr(i, 1) = rq Then
    
31.                     n = n + 1
    
32.                     If n = 1 Then
    
33.                         For j = 1 To UBound(arr, 2)
    
34.                             brr(m, j) = arr(i, j)
    
35.                         Next
    
36.                         brr(m, 9) = dm
    
37.                     End If
    
38.                 End If
    
39.             Next
    
40.         End If
    
41.     Next f
    
42.     With Sheets("Sheet1")
    
43.         .Columns("A:K") = ""
    
44.         .Columns(9).NumberFormatLocal = "@"
    
45.         .[a1].Resize(m, 9) = brr
    
46.     End With
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub test()
    Dim strFileName$, strPath$, n As Byte
    Dim vResult$(), ar, br, y&, x&, j&, r&
   
    Application.ScreenUpdating = False
    ReDim vResult(1 To 10 ^ 3, 8)
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.txt")
   
    Do Until strFileName = ""
        n = FreeFile
        Open strPath & strFileName For Input As #n
            ar = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbLf)
        Close #n
        r = r + 1
        vResult(r, UBound(vResult, 2)) = Mid(strFileName, 4, 6)
        For y = 2 To UBound(ar) - 2
            br = Split(ar(y), vbTab)
            If br(0) > vResult(r, 0) Then
                For j = 0 To UBound(br)
                    vResult(r, j) = br(j)
                Next j
            End If
        Next y
        strFileName = Dir
    Loop
   
    Columns("A:I").Clear
    [A1].Resize(r, UBound(vResult, 2) + 1) = vResult
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

lhj323323

小花鹿 发表于 2024-2-7 12:54
论坛里有遍历文件夹内文件名的代码，套上就行，就是一个Do循环：
filename=dir(thisworkbook.path & "\*.t ...

不知怎么套用。

lhj323323

ykcbf1100 发表于 2024-2-7 13:35
附件供参考。。。

本以为，在一楼的语句的基础上，添加一段代码来实现
没想到，又出现两种新写法。

liulang0808

y 新建 (3).zip (1.78 MB, 下载次数: 2)

2024-2-8 07:48 上传

点击文件名下载附件

原代码增补的

lhj323323

ykcbf1100 发表于 2024-2-7 13:36
参与一下。。。

老师：

我发现个问题
能否从下往上倒着读取数据，如果日期有减少，就止读，
这样，会不会减少读取的时间和步骤？