根据多个工作簿内工作表名称合并到汇总工作簿对应的工作表中

cqcbc · 发表于 2014-9-29 20:01

根据多个工作簿内工作表名称合并到汇总工作簿对应的工作表中
1、汇总表格式包含3个工作表,分别是《行政机构人员信息》+《事业单位人员信息》+《数据输入说明》，
2、明细表则为《事业单位人员信息》+《数据输入说明》，或者《行政机构人员信息》+《数据输入说明》，
3、需要将明细表目录下的工作簿，按工作表名称，分别合并到汇总表中的工作表中。
4、即打开工作簿，如果包含《行政机构人员信息》工作表，则合并到汇总表《行政机构人员信息》中；如果包含《事业单位人员信息》，则合并到汇总表《事业单位人员信息》中。
附件为模拟的部分数据，请各位帮帮我，谢谢。

wq0804 · 发表于 2014-9-29 21:12

多个工作簿汇总坛子里有很多例子啊

cqcbc · 发表于 2014-9-29 21:16

wq0804 发表于 2014-9-29 21:12
多个工作簿汇总坛子里有很多例子啊

我找遍了，就是没有这种类型的，自己的水平有限，请大家帮忙。

战战如疯 · 发表于 2014-9-29 22:22

Sub 汇总()
Dim wb, mypath, myfile
mypath = ThisWorkbook.Path & "\明细表"
myfile = Dir(mypath & "*.xls")
Do While myfile <> ""
Set wb = GetObject(mypath & myfile)
On Error Resume Next
With wb.Sheets("行政机构人员信息")
.Rows("3:" & .[a65536].End(xlUp).Row).Copy Sheets("行政机构人员信息").Rows([a65536].End(xlUp).Row + 1)
End With
On Error Resume Next
With wb.Sheets("事业单位人员信息")
.Rows("3:" & .[a65536].End(xlUp).Row).Copy Sheets("事业单位人员信息").Rows([a65536].End(xlUp).Row + 1)
End With
myfile = Dir
Loop
Set wb = Nothing
End Sub

复制代码

cqcbc · 发表于 2014-9-29 22:46

本帖最后由 cqcbc 于 2014-9-29 22:55 编辑

战战如疯发表于 2014-9-29 22:22

谢谢，运行后，有两处问题：
1、合并前要清除原有数据，不然重复运行宏会累加；
2、c人员信息表，合并过来，少了几行数据。
还请继续帮忙修改一下。
体会：两行代码On Error Resume Next，解决了工作表名称不匹配的问题，是吗？巧妙！！！！！

战战如疯 · 发表于 2014-9-30 08:55

本帖最后由战战如疯于 2014-9-30 08:58 编辑

cqcbc 发表于 2014-9-29 22:46
谢谢，运行后，有两处问题：
1、合并前要清除原有数据，不然重复运行宏会累加；
2、c人员信息表，合并 ...

Sub 汇总()
Dim wb, mypath, myfile
Sheets("行政机构人员信息").UsedRange.Offset(1, 0).ClearContents
Sheets("事业单位人员信息").UsedRange.Offset(1, 0).ClearContents
mypath = ThisWorkbook.Path & "\明细表"
myfile = Dir(mypath & "*.xls")
Do While myfile <> ""
Set wb = GetObject(mypath & myfile)
On Error Resume Next
With wb.Sheets("行政机构人员信息")
.Rows("3:" & .[a65536].End(xlUp).Row).Copy Sheets("行政机构人员信息").Rows(Sheets("行政机构人员信息").[a65536].End(xlUp).Row + 1)
End With
On Error Resume Next
With wb.Sheets("事业单位人员信息")
.Rows("3:" & .[a65536].End(xlUp).Row).Copy Sheets("事业单位人员信息").Rows(Sheets("事业单位人员信息").[a65536].End(xlUp).Row + 1)
End With
myfile = Dir
Loop
Set wb = Nothing
End Sub

复制代码

数据没有少，错位了，前面那个判断最后一行的代码有误

zax010 · 发表于 2014-9-30 08:57

Sub zz()
Dim f$, p$, arr, brr
Application.ScreenUpdating = False
Sheet1.[a3:aj2000] = ""
Sheet2.[a3:aj2000] = ""
On Error Resume Next
p = ThisWorkbook.Path & "\明细表\"
f = Dir(p & "*.xls")
Do While Len(f)
      If f <> ThisWorkbook.Name Then
         With GetObject(p & f)
            For i = 1 To .Sheets.Count
                  If .Sheets(i).Name = "行政机构人员信息" Then
                     arr = .Sheets(i).Range("A3:AJ" & .Sheets(i).[a65536].End(3).Row)
                  End If
                  If .Sheets(i).Name = "事业单位人员信息" Then
                     brr = .Sheets(i).Range("A3:AJ" & .Sheets(i).[a65536].End(3).Row)
                  End If
            Next
            .Close False
         End With
         With ThisWorkbook
            .Sheets("行政机构人员信息").Range("A" & .Sheets("行政机构人员信息").[a65536].End(3).Row + 1).Resize(UBound(arr), UBound(arr, 2)) = arr
            .Sheets("事业单位人员信息").Range("A" & .Sheets("事业单位人员信息").[a65536].End(3).Row + 1).Resize(UBound(brr), UBound(brr, 2)) = brr
         End With
         Erase arr: Erase brr
      End If
      f = Dir
Loop
Application.ScreenUpdating = True
End Sub

zax010 · 发表于 2014-9-30 08:58

>>>>>>>>>>>>>>>>>

按工作表名称合并明细表.rar (47.1 KB, 下载次数: 131)

kszcs · 发表于 2014-9-30 10:20

zax010 发表于 2014-9-30 08:58
>>>>>>>>>>>>>>>>>

zax010你好：
想把所有的工作簿中的表都汇总进来，修改了一下你的代码，但运行的效果没有实现--《事业单位人员信息》表汇总的信息是《数据输入说明》表里的信息。你看看错在哪？
谢谢！

cqcbc · 发表于 2014-9-30 10:20

战战如疯发表于 2014-9-30 08:55
数据没有少，错位了，前面那个判断最后一行的代码有误

再次谢谢，不错，可以汇总了。还有一点小问题：
1、我在实例中运行后，发现没关闭源表？
2、实例中，因两张人员信息表中引用了《数据输入说明》中的名称，导致运行宏的时候提示：名称已存在，更改或保持。这是我没想到的，看是不是有方法规避。

		自动登录	找回密码
密码			免费注册

[求助] 根据多个工作簿内工作表名称合并到汇总工作簿对应的工作表中

最新热点 /1