ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 228|回复: 9

[求助] 汇总多工作簿指定区域信息

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-9-17 14:54 | 显示全部楼层 |阅读模式
本帖最后由 xrdzl 于 2024-9-17 14:56 编辑

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

image.png image.jpg
image.png
image.png
image.png
image.png

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

51.27 KB, 下载次数: 15

TA的精华主题

TA的得分主题

发表于 2024-9-17 15:43 | 显示全部楼层
多工作簿汇总

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

223.57 KB, 下载次数: 24

评分

3

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-9-17 15:44 | 显示全部楼层
参与一下。。。

  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
复制代码


评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-9-17 16:02 | 显示全部楼层
参与一下,仅供参考。。。
按照数据源的标题顺序
image.png
image.png

履历汇总表.zip

16.85 KB, 下载次数: 19

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-9-17 16:03 | 显示全部楼层
代码如下。。。。
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

TA的精华主题

TA的得分主题

发表于 2024-9-17 19:00 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
汇总的例子:
2024-9-17汇总.png

TA的精华主题

TA的得分主题

发表于 2024-9-17 20:43 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
用PQ解决,轻轻松松,还能自动刷 新。。。。。。



不香?????????????????

1.png
2.png

TA的精华主题

TA的得分主题

发表于 2024-9-19 22:33 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2024-9-20 12:11 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
cnmlgb9998 发表于 2024-9-17 20:43
用PQ解决,轻轻松松,还能自动刷 新。。。。。。

香,但是没有WPS

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-9-24 21:26 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-10-5 14:12 , Processed in 0.038302 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表