求助，批量提取文件名和Q3单元格内容

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.8
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("汇总表")
   
7.     ReDim brr(1 To 1000, 1 To 2)
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.             fn = fso.GetBaseName(f)
    
11.             m = m + 1
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             brr(m, 1) = fn
    
14.             brr(m, 2) = wb.Sheets(1).[q3].Value
    
15.             wb.Close 0
    
16.         End If
    
17.     Next f
    
18.     With sh
    
19.         .UsedRange.Offset(1).Clear
    
20.         If m Then
    
21.             .[a2].Resize(m, 2) = brr
    
22.             .[a2].Resize(m, 2).Borders.LineStyle = 1
    
23.         End If
    
24.     End With
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码

limonet

关键字：hashtable

limonet

文件多，多层文件夹才有优势。
Sub limonet()
    Dim Arr As Variant, i%
    Arr = Split(CreateObject("WScript.Shell").Exec("powershell push-location " & ThisWorkbook.Path _
    & ";$h=@{};$Excel = New-Object -ComObject Excel.Application;dir .\* -exclude *.xlsm " _
    & "| % {$h[$_.name]=$excel.workbooks.Open($_.fullname).Sheets.Item(1).Range('Q3').Value();" _
    & "$Excel.Workbooks.Close()} ; $Excel.Quit();$h").StdOut.ReadAll, Chr(13) & Chr(10))
    For i = 3 To UBound(Arr) - 3
        Cells(i - 1, "A").Resize(1, 2) = Split(Application.Trim(Arr(i)))
    Next i
End Sub