麻烦大神帮忙，如何将多个工作簿表格汇总新的工作表里

yukiaikou1988

有1000多个工作簿，我只想选取其中学历部分的内容，（不要履历部分，由于履历部分设置了职工能够自动加行，导致每个人的表都不一样),想问问各位大神，vba怎么做，将提取的信息生成在学历汇总表中，我怕叙述清楚，请看附件！拜托各位大神帮帮忙，一个一个录真的眼要(*Φ皿Φ*)虾米了! xueh

570765393

解决办法：
1、统一每一张表格内容，建议如张三表，建议表内增加名字，统一把学位信息统一到上面，因工作简历信息每一个的都不相同

570765393

建议修改如张三，表内增加姓名，学位信息和工作简历信息兑换，因为每一个人的工作简历不一样
后面需要的代码自己加，应该能看得懂吧

3190496160

Sub 合并信息()
Application.ScreenUpdating = False
Dim arr()
Dim rg As Range
ReDim arr(1 To 10000, 1 To 22)
p = ThisWorkbook.Path & "\"
m = ThisWorkbook.Name
f = Dir(p & "*.xls")
Do While f <> ""
    If f <> m Then
        Set wb = Workbooks.Open(p & f)
        With wb.Worksheets(1)
            Set Rng = .Columns(1).Find("学历学位  信息", , , , , , 1)
            If Not Rng Is Nothing Then
               n = n + 1
                r = Rng.Row
                arr(n, 1) = .[b1]
                y = 1
                For i = r To r + 9
                    y = y + 1
                    arr(n, y) = .Cells(i, 3)
                Next i
                For i = r To r + 9
                    y = y + 1
                    arr(n, y) = .Cells(i, 7)
                Next i
            End If
        End With
        wb.Close fasle
    End If
f = Dir
Loop
With Sheet1
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

填报.rar (38.48 KB, 下载次数: 10)

2021-12-31 11:31 上传

点击文件名下载附件

yukiaikou1988

570765393 发表于 2021-12-31 03:01
建议修改如张三，表内增加姓名，学位信息和工作简历信息兑换，因为每一个人的工作简历不一样
后面需要的代 ...

特别感谢，谢谢大佬帮助

yukiaikou1988

3190496160 发表于 2021-12-31 11:31

用的您的公式，特别给力，万分感谢

yukiaikou1988

3190496160 发表于 2021-12-31 11:30
Sub 合并信息()
Application.ScreenUpdating = False
Dim arr()

谢谢帮助，万分感谢！

明天会更好zj

这个代码比较简单，规范的操作是你在汇总表这里新建一个文件夹，文件名叫数据源，用这个代码去汇总
str = ThisWorkbook.Path & "\数据源\"
Set wb0 = ThisWorkbook
hmc = Dir(str)
For i = 1 To 10000
    If hmc <> "" Then
        Set wb = Workbooks.Open(str & hmc)
        For j = 1 To 100
            If Left(wb.Sheets(1).Cells(j, 1), 2) = "学历" Then
                k = j
            End If
        Next j
            With wb.Sheets(1)
                wb0.Sheets(1).Cells(i + 1, 1) = .Cells(1, 2)
                wb0.Sheets(1).Cells(i + 1, 2) = .Cells(k, 3)
                wb0.Sheets(1).Cells(i + 1, 3) = .Cells(k + 1, 3)
                wb0.Sheets(1).Cells(i + 1, 4) = .Cells(k + 2, 3)
                wb0.Sheets(1).Cells(i + 1, 5) = .Cells(k + 3, 3)
                wb0.Sheets(1).Cells(i + 1, 6) = .Cells(k + 4, 3)
                wb0.Sheets(1).Cells(i + 1, 7) = .Cells(k + 5, 3)
                wb0.Sheets(1).Cells(i + 1, 8) = .Cells(k + 6, 3)
                wb0.Sheets(1).Cells(i + 1, 9) = .Cells(k + 7, 3)
                wb0.Sheets(1).Cells(i + 1, 10) = .Cells(k + 8, 3)
                wb0.Sheets(1).Cells(i + 1, 11) = .Cells(k + 9, 3)
                wb0.Sheets(1).Cells(i + 1, 12) = .Cells(k, 7)
                wb0.Sheets(1).Cells(i + 1, 13) = .Cells(k + 1, 7)
                wb0.Sheets(1).Cells(i + 1, 14) = .Cells(k + 2, 7)
                wb0.Sheets(1).Cells(i + 1, 15) = .Cells(k + 3, 7)
                wb0.Sheets(1).Cells(i + 1, 16) = .Cells(k + 4, 7)
                wb0.Sheets(1).Cells(i + 1, 17) = .Cells(k + 5, 7)
                wb0.Sheets(1).Cells(i + 1, 18) = .Cells(k + 6, 7)
                wb0.Sheets(1).Cells(i + 1, 19) = .Cells(k + 7, 7)
                wb0.Sheets(1).Cells(i + 1, 20) = .Cells(k + 8, 7)
                wb0.Sheets(1).Cells(i + 1, 21) = .Cells(k + 9, 7)
              
            End With
        wb.Close
        hmc = Dir
    End If
Next

jjmysjg

明天会更好zj 发表于 2022-1-12 20:23
这个代码比较简单，规范的操作是你在汇总表这里新建一个文件夹，文件名叫数据源，用这个代码去汇总
str =  ...

运行，str = ThisWorkbook.Path & "\数据源\"黄色。
麻烦大师给个完整代码
谢谢！