汇总多工作簿指定区域信息

xrdzl

求助：需要汇总多工作簿指定区域履历信息，从“履历信息”表头的下一行开始复制到对应的汇总表里，表头所在的行数不定，复制到“称谓”的上一行，有的有空行的需删除。

ykcbf1100

多工作簿汇总

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.17
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     ReDim brr(1 To 10000, 1 To 100)
   
6.     For Each f In fso.GetFolder(p).Files
   
7.         If LCase$(f.Name) Like "*.xls*" Then
   
8.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
9.                 fn = fso.GetBaseName(f)
   
10.                 Set wb = Workbooks.Open(f, 0)
    
11.                 With wb.Sheets(1)
    
12.                     arr = .UsedRange
    
13.                     Set Rng = .UsedRange.Find("姓名")
    
14.                     If arr(Rng.Row, 3) <> Empty Then xm = arr(Rng.Row, 3)
    
15.                     Set Rng = .UsedRange.Find("履历类别")
    
16.                     r1 = Rng.Row
    
17.                     Set Rng = .UsedRange.Find("称谓")
    
18.                     r2 = Rng.Row
    
19.                     For i = r1 + 1 To r2 - 1
    
20.                         If arr(i, 2) <> Empty Then
    
21.                             m = m + 1
    
22.                             brr(m, 1) = xm
    
23.                             brr(m, 2) = arr(i, 2)
    
24.                             brr(m, 3) = arr(i, 5)
    
25.                             brr(m, 4) = arr(i, 3)
    
26.                             brr(m, 5) = arr(i, 4)
    
27.                             brr(m, 6) = arr(i, 8)
    
28.                         End If
    
29.                     Next
    
30.                 End With
    
31.                 wb.Close 0
    
32.             End If
    
33.         End If
    
34.     Next f
    
35.     With Sheets("Sheet1")
    
36.         .[a4:f10000] = ""
    
37.         .[a4].Resize(m, 6) = brr
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    

复制代码

quqiyuan

参与一下，仅供参考。。。
按照数据源的标题顺序

quqiyuan

代码如下。。。。
Sub test()
Application.ScreenUpdating = False
    Dim rng As Range, rg As Range
    Set wb = ThisWorkbook
    p = wb.Path & "\"
    f = Dir(p & "*.xls*")
    ReDim brr(1 To 10000, 1 To 6)
    Do While f <> ""
        If f <> wb.Name Then
            With Workbooks.Open(p & f, 0).Sheets(1)
                Set rng = .UsedRange.Find("姓名")
                s = rng.Offset(, 1).Value
                Set rng = .UsedRange.Find("履历类别")
                d = Split(rng.Address, "$")(2)
                Set rg = .UsedRange.Find("称谓")
                d1 = Split(rg.Address, "$")(2)
                arr = rng.Offset(1).Resize(d1 - d - 1, 7)
                For i = 1 To UBound(arr)
                    If arr(i, 1) <> Empty Then
                        n = n + 1
                        brr(n, 1) = s
                        For j = 1 To 4
                            brr(n, j + 1) = arr(i, j)
                        Next
                        brr(n, 6) = arr(i, UBound(arr, 2))
                    End If
                Next
                .Parent.Close 0
            End With
        End If
        f = Dir
    Loop
    With wb.Sheets(1)
        .UsedRange.Clear
        .[a2] = "履历信息汇总"
        .[a2].Resize(, 6).Merge
        .[a3:f3] = [{"姓名","履历类别","起始时间","结束时间","所在单位","身份或职务"}]
        .[a4].Resize(n, 6) = brr
        .UsedRange.Offset(1).Borders.LineStyle = 1
        .UsedRange.HorizontalAlignment = xlCenter
        .UsedRange.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

蓝桥玄霜

汇总的例子：

cnmlgb9998

用PQ解决，轻轻松松，还能自动刷 新。。。。。。



不香？？？？？？？？？？？？？？？？？

blackttea1

学习啦，谢谢

jjmysjg

cnmlgb9998 发表于 2024-9-17 20:43
用PQ解决，轻轻松松，还能自动刷 新。。。。。。

香，但是没有WPS

xrdzl

jjmysjg 发表于 2024-9-20 12:11
香，但是没有WPS

对，我也是