求抓取固定sheet的所有内容的VBA代码

wy45855018

大家好，有一个小工具我在用函数做，但做到后面发现要执行的函数太多了，所以现在请教各位帮忙给提供一段代码，谢谢。
规则：
1、附件有7个姓名sheet

2、将7个姓名sheet的内容抓取到“Overdue Report”sheet内：
a. 7个姓名sheet内容只要H2到N2列之间的全部行数
b.抓取到的7个姓名sheet的内容以此放到“Overdue Report”sheet 中的AJ到AP列中， 但要从第二行放，第一行标题要保留，不覆盖
c.内容依次放，不留空行哈，其他的单元格内容格式不变，可供我自己改内容


其实这个表的目的就是 将每个人确认的信息 自动放到 Overdue Report内的固定位置，接下来给其他人做报告使用


我已经用函数处理到这一步了，接下来 非常感谢

游帅帅

这个代码我认为可以满足你的需求，是我从b站一位大神的分享学来的，你试试

1. Sub 合并数据()
   
2.     Dim sht As Worksheet
   
3.     Dim rng As Range
   
4.     Dim k
   
5.     Dim n
   
6.     Dim a
   
7.     Application.ScreenUpdating = False
   
8.     '取消屏幕更新
   
9.     '---------------需要在选择汇总表才能操作
   
10.     If ActiveSheet.Name <> "汇总表" Then
    
11.         MsgBox "请新建或选择表名为：汇总表的表格再执行该操作"
    
12.         
    
13.         Exit Sub
    
14.     End If
    
15.    
    
16.     '---------------删除原先的内容
    
17.     a = ActiveSheet.UsedRange.Rows.Count '获取最后非空单元格的行号
    
18.    
    
19.     For i = a + 1 To n + 1 Step -1
    
20.         
    
21.         Rows(i).Delete
    
22.         
    
23.     Next
    
24.    
    
25.     n = Val(InputBox("请输入标题的行数", "提醒"))
    
26.    
    
27.     '--------------合并表
    
28.    
    
29.     If n < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
    
30.     '取得用户输入的标题行数，如果为负数，退出程序
    
31.     Cells.ClearContents
    
32.     '清空当前表数据
    
33.    
    
34.     For Each sht In Worksheets
    
35.         '遍历工作表
    
36.         
    
37.         If sht.Name <> ActiveSheet.Name Then
    
38.             '如果工作表名称不等于当前表名则进行汇总动作……
    
39.             Set rng = sht.UsedRange
    
40.             '定义rng为表格已用区域
    
41.             k = k + 1
    
42.             '累计K值
    
43.             
    
44.             If k = 1 Then
    
45.                 '如果是首个表格，则K为1，则把标题行一起复制到汇总表
    
46.                 rng.Copy
    
47.                 [a1].PasteSpecial Paste:=xlPasteValues         '仅粘贴数值
    
48.             Else
    
49.                 '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
    
50.                 rng.Offset(n).Copy
    
51.                 Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
    
52.             End If
    
53.             
    
54.         End If
    
55.         
    
56.     Next
    
57.    
    
58.     [a1].Activate
    
59.     Application.ScreenUpdating = True '恢复屏幕刷新
    
60. End Sub

复制代码