Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1565|回复: 7

多表合并,在线等。

[复制链接]
发表于 2020-4-2 11:43 | 显示全部楼层 |阅读模式
本帖最后由 victory610 于 2020-4-2 14:41 编辑

我有许多分公司的表,每张表又有多个Sheet页,现在想去掉无用的抬头,并添加一列:项目名称,然后汇总所有的Sheet到一张表上。
具体详见附件。
谢谢大神帮助!


我把内容重新修改了一下,由于敲错了。 test.rar (54.76 KB, 下载次数: 5)
发表于 2020-4-2 12:54 | 显示全部楼层
这种简单合并用复制粘贴很快的,只要不超过20个表的数据,复制粘贴就是几分钟的事情;
既然在这里回复了,也不能只是说说,给你写了个简单的代码,放在主表中运行:

Application.ScreenUpdating = False
Dim arr
arr = GetFiles(ThisWorkbook.Path)
s1 = UCase(ThisWorkbook.Name)
s2 = Mid(s1, InStr(s1, ".XL") - 3, 3)
If [a100000].End(3).Row > 1 Then
   Range(Cells(2, 1), Cells([a100000].End(3).Row, 6)).ClearContents
End If
Dim wb As Workbook
For i = 1 To UBound(arr)
    If InStr(arr(i), s2) = 0 Then
       Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & arr(i))
       For k = 1 To wb.Worksheets.Count
           wb.Worksheets(k).Activate
           Range("a4:e" & wb.Worksheets(k).[a100000].End(3).Row).Copy
           ThisWorkbook.Activate
           Range("b" & [a100000].End(3).Row + 1).Select
           Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
              :=False, Transpose:=False
           Application.CutCopyMode = False
           For j = [a100000].End(3).Row + 1 To [b100000].End(3).Row
               Cells(j, 1) = Mid(Cells(j, 2), 1, 1) & "公司"
           Next j
       Next k
       wb.Close
    End If
Next i
Application.ScreenUpdating = True
End Sub

Function GetFiles(myPath As String)
Dim myArr()
myJs = 0
Set myFolder = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
For Each mySubfile In myFolder.Files
    myJs = myJs + 1
    ReDim Preserve myArr(1 To myJs)
    myArr(UBound(myArr)) = mySubfile.Name
Next
GetFiles = myArr
End Function


有两个问题:
1、你把主表的名称叫做“需要得到的结果.xlsx”,这种叫法很碍事,我也不知道真正的文件名是什么,代码过滤也就这么来了,自己修改:
     s2 = Mid(s1, InStr(s1, ".XL") - 3, 3)

     为了预防主表文件名称的飘忽不定,我想弄得智能化一点,所以截取了从扩展名往前的3个字符作为过滤条件,这里就有个问题:如果你的文件名称只有2个文字呢,比如“主表.xls”或者“汇总.xls”,那就有问题了,要把数字3改成数字2;
     能不能截取更长一点或者更短一点呢?都有缺陷,比如主表叫“汇总数据”,明细表叫“明细数据”,截取两位反而分不开了,必须3以上才行;
     总之就是要你的文件命名规范就行了,不论随便乱叫,因为主表是不能重复打开的,在打开明细表的时候,需要把主表自己过滤掉;
2、另一个问题是,a列添加的都是"a公司"、“b公司”这些,这名称我也不知道哪来的,你的子文件是分公司1、分公司2...所以我琢磨半天,只有合同号里面有字母a\b\c\d,所以我就截取了合同编号的第一个字母+“公司”,我估摸着也不像,反正看不懂,你将就试一下吧;

评分

参与人数 1学分 +2 收起 理由
victory610 + 2

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2020-4-2 14:17 | 显示全部楼层
hfwufanhf2006 发表于 2020-4-2 12:54
这种简单合并用复制粘贴很快的,只要不超过20个表的数据,复制粘贴就是几分钟的事情;
既然在这里回复了, ...

非常感谢
回复

使用道具 举报

 楼主| 发表于 2020-4-2 14:25 | 显示全部楼层
hfwufanhf2006 发表于 2020-4-2 12:54
这种简单合并用复制粘贴很快的,只要不超过20个表的数据,复制粘贴就是几分钟的事情;
既然在这里回复了, ...

我敲错了,A列就是A项目,B项目,C项目,D项目,就是取项目名称。
回复

使用道具 举报

 楼主| 发表于 2020-4-2 14:43 | 显示全部楼层



回复

使用道具 举报

 楼主| 发表于 2020-4-2 14:44 | 显示全部楼层
hfwufanhf2006 发表于 2020-4-2 12:54
这种简单合并用复制粘贴很快的,只要不超过20个表的数据,复制粘贴就是几分钟的事情;
既然在这里回复了, ...

我已经修改了敲错的内容了,另外这样的表有300多张,肯定不能用手工来操作的,我只是举了2个表作为示例而已。
回复

使用道具 举报

发表于 2020-4-2 14:44 | 显示全部楼层
本帖最后由 hfwufanhf2006 于 2020-4-2 14:46 编辑
victory610 发表于 2020-4-2 14:25
我敲错了,A列就是A项目,B项目,C项目,D项目,就是取项目名称。

把代码稍微改一下,看下面的代码局部:
           wb.Worksheets(k).Activate

在这里插入一行:
          s3=cells(2,2)         '读取b2的项目名称

           Range("a4:e" & wb.Worksheets(k).[a100000].End(3).Row).Copy
           ThisWorkbook.Activate
           Range("b" & [a100000].End(3).Row + 1).Select
           Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
              :=False, Transpose:=False
           Application.CutCopyMode = False
           For j = [a100000].End(3).Row + 1 To [b100000].End(3).Row
               Cells(j, 1) = Mid(Cells(j, 2), 1, 1) & "公司"

这里的写入修改成:
               Cells(j, 1) = s3                   '写入之前读取的项目名称,注意上面一行Cells(j, 1) = Mid(Cells(j, 2), 1, 1) & "公司"要删掉



          Next j

评分

参与人数 1学分 +2 收起 理由
victory610 + 2

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2020-4-2 15:16 | 显示全部楼层
hfwufanhf2006 发表于 2020-4-2 14:44
把代码稍微改一下,看下面的代码局部:
           wb.Worksheets(k).Activate

感谢!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 01:25 , Processed in 0.306340 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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