这次VBA的目标就是把不同工作表内的不同表头(即列标题有所不同)的表格进行汇总到一张表内。

先来看下这张汇总表格有什么地方是值得注意的：列标题与数据是一一对应的，来自哪个表的数据就对应行标题来自哪个表格

列标题汇总了所有的列标题(项目名称)，避免了重复

数据填充在相应的单元格，没有数据的地方就留空

思路

因为列标题是汇总的，没有重复的，所以就先想到可以利用字典来进行汇总，同时排除了重复项。又因为数据要填充到相应的单元格，即要有对应的行号和列号，就选择用列标题的值和列标题对应的item进行标号，以确保数据能进入正确的单元格。利用一个循环找到操作一张表格的起始行号和结束行号，对第一列进行填充，以达到粘贴的数据与行标题是对应的效果。

简而言之，分为以下几步：遍历工作表，取出不同的标题行名称

遍历每一列，把每一列的数据复制到合并表

命名对应的行标题

实战

遍历工作表1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18Set d = CreateObject("scripting.dictionary")

Set newst = Sheets.Add

newst.Name = "合并"

m = 2

For Each sh In Sheets

If sh.Name <> "合并" Then

For i = 1 To sh.UsedRange.Columns.Count

If Not d.exists(sh.Cells(1, i).Value) Then

d(sh.Cells(1, i).Value) = m

m = m + 1

End If

Next i

End If

Next sh

newst.Range("A2") = "工作表"

newst.Range(Cells(1, 2), Cells(1, d.Count + 1)) = d.keys

建立一个字典，对一个文档中的所有工作表进行遍历，对凡是名字不叫合并的表，取出首行的标题名称，检查是否在字典关键字中，若没有就添加到关键字，并指定item。item的命名是有讲究的，因为可以直接用来对应粘贴数据值。由于数据是从第二列开始粘贴的(第一列是显示对应的工作表名称)，所以item的命名也从2开始。最后把字典中的关键字(不同的标题名称)赋值给合并表中的首行单元格。

复制数据1

2

3

4

5

6

7

8

9

10For Each sh In Sheets

If sh.Name <> "合并" Then

r = newst.UsedRange.Rows.Count + 1

For i = 1 To sh.UsedRange.Columns.Count

sh.UsedRange.Columns(i).Offset(1).Copy newst.Cells(r, d(sh.Cells(1, i).Value))

Next i

r2 = newst.UsedRange.Rows.Count

newst.Range("A" & r & ":A" & r2) = sh.Name

End If

Next sh

同样使用循环遍历所有的工作表，只是将中间的字典部分进行了更换。把一张工作表中的数据都粘贴到合并表中，其中粘贴的内容要向下横移一行(offset)，因为首行是标题行，不需要粘贴。

合并表中的标题行是唯一值，所以序列号与单张表中的标题行序列肯定是不匹配的，如何确保特定列的内容能准确无误的粘贴进相应的列当中呢？这就要用到我们之前为关键字指定的item，通过keys查找item的值，我们可以确定对应的列在合并表中是哪一列，以进行定位。

确定粘贴的行数就相对简单些，因为只要在使用过的行以下进行粘贴就好了。但是要注意的是由于我们是对一个文档中所有的工作表进行遍历循环，所以行数的增加(r = newst.UsedRange.Rows.Count + 1)应当放在遍历列循环的外面，否则每完成一列的粘贴，行数就会往下错，导致数据粘贴成阶梯形状(自己动手试试或者脑补吧 =_=)

命名行标题

最后利用r和r2来确定遍历一个工作表的起始行和结束行，将这几行的第一列命名为相应的表名即可。

全部代码1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42Sub combin()

Dim d As Object

Dim newst As Worksheet

Dim sh As Worksheet

Dim m

Dim r, r2

Dim i

Set d = CreateObject("scripting.dictionary")

Set newst = Sheets.Add

newst.Name = "合并"

m = 2

For Each sh In Sheets

If sh.Name <> "合并" Then

For i = 1 To sh.UsedRange.Columns.Count

If Not d.exists(sh.Cells(1, i).Value) Then

d(sh.Cells(1, i).Value) = m

m = m + 1

End If

Next i

End If

Next sh

newst.Range("A2") = "工作表"

newst.Range(Cells(1, 2), Cells(1, d.Count + 1)) = d.keys

For Each sh In Sheets

If sh.Name <> "合并" Then

r = newst.UsedRange.Rows.Count + 1

For i = 1 To sh.UsedRange.Columns.Count

sh.UsedRange.Columns(i).Offset(1).Copy newst.Cells(r, d(sh.Cells(1, i).Value))

Next i

r2 = newst.UsedRange.Rows.Count

newst.Range("A" & r & ":A" & r2) = sh.Name

End If

Next sh

Set d = Nothing

End Sub

总结

运用字典的时候可以巧妙的运用keys和item的对应关系进行单元格定位，这样可以减少很多的工作量并且非常有效的达到目的。