用 VBA 将多个 Excel 文件里的数据汇总到一个 Excel 表

需求

给出一个空汇总表,和若干单独的 Excel 文件,每个文件里头有一个表格里存有一个人的信息,要将这些文件里的信息全部对应地导入到汇总表里。

以前写的,也不给实际例子了,直接上代码,逻辑不复杂,看看就明白。记在这里备以后查。

代码

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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
Sub ExportMyFile()
Dim myPath, myFileName
Dim myCurOpenWB As Workbook 'work工作簿
Dim myCurOpenWS As Worksheet 'work工作表
Dim myTotalWS As Worksheet '汇总工作表

Dim myFolderName As String
myFolderName = "六堰"

Set myTotalWS = ThisWorkbook.Sheets("附件4") '汇总到表名为附件4的表格里

myPath = ThisWorkbook.Path & "/" & myFolderName & "/*.xls"
myFileName = Dir(myPath) '''''''''''''''''''''''''''''''''''
'Dim iCounter As Integer
'iCounter = 0

'遍历指定目录下的文件并操作
Do '''''''''''''''''''''''''''''''''''''
Debug.Print myFileName

Dim searchStr As String '通用搜索字符串
Dim resStr As String '通用结果字符串
Dim iCount As Integer '通用计数器

myFileName = ThisWorkbook.Path & "/" & myFolderName & "/" & myFileName

'打开指定目录里的一个*.xls文件
'Debug.Print myFileName
Set myCurOpenWB = Workbooks.Open(myFileName)
Set myCurOpenWS = myCurOpenWB.Sheets("附件1") '打开文件的sheet附件1里是分条数据

'插入内容行
Dim iC As Integer
For iC = 0 To 3
'插入内容行
myTotalWS.Rows(6).Insert
myTotalWS.Rows(6).RowHeight = 14.25
myTotalWS.Range("B6:Q6").NumberFormat = "@" '将它们的数字格式设置成文本
Next

'##################################复制数据过程######################################
'序号 =Row()-5
myTotalWS.Range("A6").Formula = "=INT(Row()/4)"

'姓名 C4
myTotalWS.Range("B6").Value = myCurOpenWS.Range("C4").Value

'性别 F4
myTotalWS.Range("C6").Value = myCurOpenWS.Range("F4").Value

'出生年月 C6
myTotalWS.Range("D6").Value = myCurOpenWS.Range("C6").Value

'身份证 D8
myTotalWS.Range("E6").Value = myCurOpenWS.Range("D8").Value

'进厂劳动时间 B21-B25
myTotalWS.Range("F6").Value = myCurOpenWS.Range("B21").Value
myTotalWS.Range("F7").Value = myCurOpenWS.Range("B22").Value
myTotalWS.Range("F8").Value = myCurOpenWS.Range("B23").Value
myTotalWS.Range("F9").Value = myCurOpenWS.Range("B24").Value

'离岗时间 B21-B25

'劳动年限 I26
myTotalWS.Range("H6").Value = myCurOpenWS.Range("I26").Value

'原用工单位 D21-D25
'myTotalWS.Range("I6").Value = myFolderName
myTotalWS.Range("I6").Value = myCurOpenWS.Range("D21").Value
myTotalWS.Range("I7").Value = myCurOpenWS.Range("D22").Value
myTotalWS.Range("I8").Value = myCurOpenWS.Range("D23").Value
myTotalWS.Range("I9").Value = myCurOpenWS.Range("D24").Value

'用工类别 D26
myTotalWS.Range("J6").Value = "家属工"

'已享受保障 B28-B30
searchStr = myCurOpenWS.Range("B28").Value
resStr = ""
iCount = 0
If InStr(searchStr, "√") <> 0 Then
resStr = resStr & "城市最低生活保障"
iCount = iCount + 1
End If
searchStr = myCurOpenWS.Range("B29").Value
If InStr(searchStr, "√") <> 0 Then
If iCount <> 0 Then
resStr = resStr & "、"
End If
resStr = resStr & "遗属生活困难补助"
iCount = iCount + 1
End If
searchStr = myCurOpenWS.Range("B30").Value
If InStr(searchStr, "√") <> 0 Then
If iCount <> 0 Then
resStr = resStr & "、"
End If
resStr = resStr & "供养亲属抚恤费"
End If
myTotalWS.Range("K6").Value = resStr

'已参加社保 B32-B34
searchStr = myCurOpenWS.Range("B32").Value
resStr = ""
iCount = 0
If InStr(searchStr, "√") <> 0 Then
resStr = resStr & "企业职工养老保险"
iCount = iCount + 1
End If
searchStr = myCurOpenWS.Range("B33").Value
If InStr(searchStr, "√") <> 0 Then
If iCount <> 0 Then
resStr = resStr & "、"
End If
resStr = resStr & "灵活就业人员养老保险"
iCount = iCount + 1
End If
searchStr = myCurOpenWS.Range("B34").Value
If InStr(searchStr, "√") <> 0 Then
If iCount <> 0 Then
resStr = resStr & "、"
End If
resStr = resStr & "城镇居民医疗保险"
End If
myTotalWS.Range("L6").Value = resStr

'配偶姓名 C10
myTotalWS.Range("M6").Value = myCurOpenWS.Range("C10").Value

'配偶现所在单位
myTotalWS.Range("N6").Value = "重型车厂"

'配偶人员类别 C12
'myTotalWS.Range("O6").Value = myCurOpenWS.Range("C12").Value
searchStr = myCurOpenWS.Range("C12").Value
If InStr(searchStr, "√去世") <> 0 Then
myTotalWS.Range("O6").Value = "去世"
ElseIf InStr(searchStr, "√离休") <> 0 Then
myTotalWS.Range("O6").Value = "离休"
ElseIf InStr(searchStr, "√退休") <> 0 Then
myTotalWS.Range("O6").Value = "退休"
ElseIf InStr(searchStr, "√退养") <> 0 Then
myTotalWS.Range("O6").Value = "退养"
Else
myTotalWS.Range("O6").Value = "在职"
End If


'备注
myTotalWS.Range("P6").Value = myFolderName

'联系电话
myTotalWS.Range("Q6").Value = myCurOpenWS.Range("H18").Value

'################################复制数据过程结束#############################

'关闭打开的文件
myCurOpenWB.Close

myFileName = Dir ''''''''''''''''''''''''''''''
' iCounter = iCounter + 1
Loop Until myFileName = "" '''''''''''''''''''''''''''''

End Sub