提取多个自定义指定单元格内容

jivy1212

提取指定文件夹内多个工作簿中，自定义的指定多个单元格内容生成新的表单，见下图红色部分，提取结果见附件。
麻烦懂的老师帮忙下，谢谢。

excel玉米

一执成念

https://club.excelhome.net/thread-1706015-1-1.html

一执成念

https://club.excelhome.net/thread-1706015-1-1.html

excel玉米

你这里条件表里第二行，提取几个sheet 只需要设置第一个单元格就行了吧？

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.15
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & "\源文件"
   
5.     Set ws = ThisWorkbook
   
6.     Set Sh = ws.Sheets("提取结果示例")
   
7.     Dim tm: tm = Timer
   
8.     With ws.Sheets("提取条件")
   
9.         fns = .[b2].Resize(, 9).Value
   
10.         zrr = .[b3].Resize(, 9).Value
    
11.     End With
    
12.     ReDim brr(1 To 10000, 1 To 100)
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If LCase$(f.Name) Like "*.xlsx" Then
    
15.             m = m + 1
    
16.             brr(m, 1) = m
    
17.             Set wb = Workbooks.Open(f, 0)
    
18.             For x = 1 To UBound(fns)
    
19.                 If fns(1, x) <> Empty Then
    
20.                     With wb.Sheets(fns(1, x))
    
21.                         n = 1
    
22.                         For j = 1 To UBound(zrr, 2)
    
23.                             If zrr(1, j) <> Empty Then
    
24.                                 n = n + 1
    
25.                                 brr(m, n) = .Range(zrr(1, j)).Value
    
26.                             End If
    
27.                         Next
    
28.                     End With
    
29.                 End If
    
30.             Next
    
31.             wb.Close 0
    
32.         End If
    
33.     Next f
    
34.     With Sh
    
35.         .UsedRange.Offset(1).ClearContents
    
36.         .[a2].Resize(m, 7) = brr
    
37.     End With
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
40. End Sub
    

复制代码

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。。
Sub test()
    Application.ScreenUpdating = False
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("提取条件")
    Set sh = wb.Sheets("提取结果示例")
    p = wb.Path & "\源文件\"
    arr = sht.[a1].CurrentRegion
    '    ReDim ar(1 To 1)
    ReDim br(1 To 1)
    n = 0
    For i = 2 To UBound(arr, 2)
        n = n + 1
        If arr(2, i) <> Empty Then x = arr(2, i)
        If arr(3, i) <> Empty Then ReDim Preserve br(1 To n): br(n) = arr(3, i)
    Next
    n = 0
    f = Dir(p & "*.xls*")
    ReDim brr(1 To 10000, 1 To UBound(br) + 1)
    Do While f <> ""
        With Workbooks.Open(p & f, 0)
            For i = 1 To x
                With .Sheets(x)
                    n = n + 1
                    brr(n, 1) = n
                    For j = 1 To UBound(br)
                        brr(n, j + 1) = .Range(br(j))
                    Next
                End With
            Next
            .Close 0
        End With
        f = Dir
    Loop
    With sh
        .[j1].CurrentRegion.Clear
        .[j1].Resize(, UBound(brr, 2)) = [{"序号","名称","箱    种","箱子型号","数    量","参考重量","产品单重"}]
        .[j2].Resize(6, UBound(brr, 2)) = brr
        .[j1].CurrentRegion.HorizontalAlignment = xlCenter
        .[j1].CurrentRegion.Borders.LineStyle = 1
        .[j1].CurrentRegion.Columns.AutoFit
    End With
    Beep
    Application.ScreenUpdating = True
End Sub

松永

添加一辅助表。仅做参考。