vba汇总-将文件夹内表格在汇总表里面建立分表，并汇总

761680941

要求将“人员”文件内的各表内第一张表A1:R200复制到“汇总表”之中，并且要求汇总表内建立分表进行汇总，每个分表名字同各人员名字要相同（如果这步做不到，我可以先命名好各分表的名字，要求各表负责到各自的分表之中），而且内容是选择性粘贴的；
或者将“人员”文件内的各表第一张表A1:R200复制到“汇总表”之中的任意一张表。
谢谢各位

fxl447098457

1. Sub getdata()
   
2. Dim FilePath$, FileName$, Str$, Arr, Sh As Worksheet
   
3. Application.ScreenUpdating = False
   
4. On Error Resume Next
   
5. FilePath = ThisWorkbook.Path & "\人员"
   
6. FileName = Dir(FilePath & "*.xls?")
   
7. Do While Len(FileName)
   
8.     With GetObject(FilePath & FileName)
   
9.         Arr = .Sheets(1).UsedRange
   
10.         Str = Split(.Name, ".xls")(0)
    
11.         .Close 0
    
12.     End With
    
13. If Sheets(Str) Is Nothing Then Sheets.Add.Name = Str
    
14.     Set Sh = Sheets(Str)
    
15.     Sh.UsedRange.ClearContents
    
16.     Sh.[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    
17.     FileName = Dir
    
18. Loop
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

新建文件夹.rar (39.73 KB, 下载次数: 45)

2016-10-25 16:54 上传

点击文件名下载附件

761680941

fxl447098457 发表于 2016-10-25 16:54

谢谢 明天上班试试

761680941

fxl447098457 发表于 2016-10-25 16:54

大师 我问下如果我需要保留表格的原有格式和框架，需要怎么改；另外改哪个代码可以变更我需要复制的范围

761680941

谁来帮我解决下啊

LMY123

改Arr可以控制数据范围

761680941

LMY123 发表于 2016-10-26 12:54
改Arr可以控制数据范围

具体怎么改，另外保留原来的格式字体怎么改

LMY123

761680941 发表于 2016-10-26 14:24
具体怎么改，另外保留原来的格式字体怎么改

参考:

1. Sub test()
   
2.    Dim w As Workbook, sh As Worksheet, MyPath As String, MyName  As String
   
3.       Application.ScreenUpdating = False
   
4.       Set d = CreateObject("scripting.dictionary")
   
5.     For Each sh In Sheets
   
6.       d(sh.Name) = ""
   
7.     Next
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     MyName = Dir(MyPath & "*.xls")
   
10.   Do While MyName <> ""
    
11.      If MyName <> ThisWorkbook.Name Then
    
12.         With ThisWorkbook
    
13.             Set w = CreateObject(.Path & "" & MyName)
    
14.           For Each sh In w.Worksheets
    
15.              If d.Exists(sh.Name) Then _
    
16.                sh.Range("B8:D10").Copy .Worksheets(sh.Name).[a65536].End(3)(1, 1)
    
17.           Next
    
18.              Windows(w.Name).Visible = True
    
19.              w.Close False
    
20.        End With
    
21.      End If
    
22.          MyName = Dir
    
23.    Loop
    
24.      Set d = Nothing
    
25.      Set w = Nothing
    
26.    ActiveWorkbook.RemovePersonalInformation = False
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "数据处理完毕。"
    
29. End Sub
    

复制代码

761680941

LMY123 发表于 2016-10-26 15:21
参考:

能不能将复制的范围 在改代码后面备注汉字，然后怎么修改

LMY123

761680941 发表于 2016-10-31 13:23
能不能将复制的范围 在改代码后面备注汉字，然后怎么修改

sh.Range("B8:D10").Copy .Worksheets(sh.Name).[a65536].End(3)(1, 1),调整红色区域