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

菊子红了

大神们，求助，想批量提取文件名到A列，对应表格Q3单元格内容到C列。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, r&, strFileName$, strPath$, wks As Worksheet
   
    Application.ScreenUpdating = False
    ReDim ar(1 To 10 ^ 4, 2)
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsx")
   
    Do Until strFileName = ""
        With GetObject(strPath & strFileName)
            For Each wks In .Worksheets
                r = r + 1
                ar(r, 0) = strFileName
                ar(r, 1) = wks.Name
                ar(r, 2) = wks.[Q3].Value
            Next
            .Close False
        End With
        strFileName = Dir
    Loop
   
    If r Then [A1].Resize(r, 3) = ar
    Set wks = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。

菊子红了

gwjkkkkk 发表于 2024-6-8 12:38
。。。。。。。。

没看懂，能指点一下吗？

quqiyuan

参与一下

quqiyuan

代码如下

Sub test()
Application.ScreenUpdating = False
    Set fso = CreateObject("scripting.filesystemobject")
    Set ws = ThisWorkbook.Sheets(1)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择目标文件夹"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then p = .SelectedItems(1) Else MsgBox "没有选定数据源的文件夹，退出！！": Exit Sub
    End With
    wb_name = fso.getbasename(ThisWorkbook.Name)
    ws.UsedRange.ClearContents                     '这个看需要啦，如果每次都要新的，就要，如果在后面添加就取消
    For Each f In fso.getfolder(p).Files
        If InStr(f.Name, wb_name) = 0 Then
            If LCase(f.Name) Like "*.xls*" Then
                r = ws.Cells(Rows.Count, 1).End(3).Row + 1
                With Workbooks.Open(f, 0).Sheets(1)
                    ws.[a1] = "文件名": ws.[c1] = "内容"
                    ws.Cells(r, 1) = f.Name
                    ws.Cells(r, 3) = .[q3]
                    .Parent.Close 0
                End With
            End If
        End If
    Next
Application.ScreenUpdating = True
    Beep
End Sub

菊子红了

quqiyuan 发表于 2024-6-8 13:39
参与一下

Sub test()
Application.ScreenUpdating = False
    Set fso = CreateObject("scripting.filesystemobject")
    Set ws = ThisWorkbook.Sheets(1)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "C:\Users\tqc-00332\Desktop\01\"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then p = .SelectedItems(1) Else MsgBox "没有选定数据源的文件夹，退出！！": Exit Sub
    End With
    wb_name = fso.getbasename(ThisWorkbook.Name)
    ws.UsedRange.ClearContents                     '这个看需要啦，如果每次都要新的，就要，如果在后面添加就取消
    For Each f In fso.getfolder(p).Files
        If InStr(f.Name, wb_name) = 0 Then
            If LCase(f.Name) Like "*.xls*" Then
                r = ws.Cells(Rows.Count, 1).End(3).Row + 1
                With Workbooks.Open(f, 0).Sheets(1)
                    ws.[a1] = "文件名": ws.[c1] = "内容"
                    ws.Cells(r, 1) = f.Name
                    ws.Cells(r, 3) = .[q3]
                    .Parent.Close 0
                End With
            End If
        End If
    Next
Application.ScreenUpdating = True
    Beep
End Sub

菊子红了

quqiyuan 发表于 2024-6-8 13:40
代码如下

Sub test()

我修改了文件夹路径，但提示退出。不知道原因出在哪里？

菊子红了

gwjkkkkk 发表于 2024-6-8 12:38
Option Explicit
Sub test()
    Dim ar, i&, r&, strFileName$, strPath$, wks As Worksheet

Option Explicit
Sub test()
    Dim ar, i&, r&, strFileName$, strPath$, wks As Worksheet
   
    Application.ScreenUpdating = False
    ReDim ar(1 To 10 ^ 4, 2)
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls")
   
    Do Until strFileName = " C:\Users\tqc-00332\Desktop\01\""
        With GetObject(strPath & strFileName)
            For Each wks In .Worksheets
                r = r + 1
                ar(r, 0) = strFileName
                ar(r, 1) = wks.Name
                ar(r, 2) = wks.[Q3].Value
            Next
            .Close False
        End With
        strFileName = Dir
    Loop
   
    If r Then [A1].Resize(r, 3) = ar
    Set wks = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

我改了一下路径，运行后表格显示灰色，无内容。

quqiyuan

菊子红了 发表于 2024-6-8 14:13
我修改了文件夹路径，但提示退出。不知道原因出在哪里？