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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
| Dim a, b, c As Integer '宣告a,b,c為整數
Dim objsheet As Worksheet
Dim sheetname As String '工作表檔名
Dim ispastervalue As String '是否要選擇性貼上值及格式
Source = Excel.ActiveWorkbook.Name '新檔案視窗編號
n = Range("b3")
m = Range("b4")
x = Range("b5")
y = Range("b6")
display_sheetname = UCase(Range("b7"))
display_row_sheetname = UCase(Range("b8"))
insert_page = UCase(Range("b9"))
insert_row = Range("b10")
ispastervalue = UCase(Range("b11"))
'將之前合併的結果清除
Sheet2.Cells.Delete Shift:=xlUp
z = 1
i = 1
Filename = Range("b" & i) & "." & Range("b2")
FullPath = Excel.Workbooks(Source).Path & "\" & Filename
'檢查檔案是否存在
If Dir(FullPath) = "" Then '檢查檔案是否存在
MsgBox "檔案:" & FullPath & "不存在，請查看是否有拼錯字"
Exit Sub
End If
Workbooks.Open Filename:=Excel.Workbooks(Source).Path & "\" & Filename
WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
i = 12
sheetname = Trim(Windows(Source).ActiveSheet.Range("b" & i))
If sheetname = "" Then
For j = 1 To Sheets.Count
x = Range("b5")
y = Range("b6")
Windows(WorkName).Activate
Set objsheet = Sheets(j) '切換視窗
objsheet.Activate
'讀取來源檔案的X(列數),Y(行數)
If x = 0 Then
x = n
Do While True
kk = ""
For l = 1 To 10
For k = 1 To 10
If IsError(objsheet.Cells(x + l, k)) = False Then
kk = kk & objsheet.Cells(x + l, k)
End If
Next
Next
If kk = "" Then Exit Do
x = x + 1
Loop
End If
If y = 0 Then
y = m
Do While True
kk = ""
For l = 1 To 10
For k = 1 To 10
If IsError(objsheet.Cells(k, y + l)) = False Then
kk = kk & objsheet.Cells(k, y + l)
End If
Next
Next l
If kk = "" Then Exit Do
y = y + 1
Loop
End If
'選取目的
Windows(WorkName).Activate
'選取來源範圍
objsheet.Range(objsheet.Cells(n, m), objsheet.Cells(x, y)).Select
'copy
Selection.Copy
Windows(Source).Activate
Sheet2.Activate
If (display_row_sheetname = "Y") Then
If display_sheetname = "Y" Then
Sheet2.Cells(z, 1) = objsheet.Name
Sheet2.Cells(z, 2) = objsheet.Name
Else
Sheet2.Cells(z, 1) = objsheet.Name
End If
o = 1
Else
o = 0
End If
If display_sheetname = "Y" Then
Sheet2.Cells(z + o, 2).Select
For k = z To z + x - n + o
Sheet2.Cells(k, 1) = objsheet.Name
Next
Else
Sheet2.Cells(z + o, 1).Select
End If
If (z > 3 And insert_page = "Y") Then
If display_row_sheetname = "Y" Then
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=ActiveCell.Offset(-1, 0)
Else
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=ActiveCell
End If
End If
If ispastervalue = "Y" Then
Sheet2.Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Else
ActiveSheet.Paste
End If
z = z + x - n + 1 + insert_row + o
'將來源檔案關閉
'Windows(Filename).Close
i = i + 1 '讀取下一個檔案名稱
Sheet1.Activate
Next
Else
While sheetname <> ""
x = Range("b5")
y = Range("b6")
Windows(WorkName).Activate
'檢查活頁是否存在
isfind = False
For Each st In Sheets
If st.Name = sheetname Then
isfind = True
Exit For
End If
Next
If isfind = False Then
MsgBox "工作表:" & sheetname & "不存在，請查看是否有拼錯字"
Exit Sub
End If
Set objsheet = Sheets(sheetname) '切換視窗
objsheet.Activate
'讀取來源檔案的X(列數),Y(行數)
If x = 0 Then
x = n
Do While True
kk = ""
For l = 1 To 10
For k = 1 To 10
If IsError(objsheet.Cells(x + l, k)) = False Then
kk = kk & objsheet.Cells(x + l, k)
End If
Next
Next
If kk = "" Then Exit Do
x = x + 1
Loop
End If
If y = 0 Then
y = m
Do While True
kk = ""
For l = 1 To 10
For k = 1 To 10
If IsError(objsheet.Cells(k, y + l)) = False Then
kk = kk & objsheet.Cells(k, y + l)
End If
Next
Next l
If kk = "" Then Exit Do
y = y + 1
Loop
End If
'選取目的
Windows(WorkName).Activate
'選取來源範圍
objsheet.Range(objsheet.Cells(n, m), objsheet.Cells(x, y)).Select
'copy
Selection.Copy
Windows(Source).Activate
Sheet2.Activate
If (display_row_sheetname = "Y") Then
If display_sheetname = "Y" Then
Sheet2.Cells(z, 1) = objsheet.Name
Sheet2.Cells(z, 2) = objsheet.Name
Else
Sheet2.Cells(z, 1) = objsheet.Name
End If
o = 1
Else
o = 0
End If
If display_sheetname = "Y" Then
Sheet2.Cells(z + o, 2).Select
For k = z To z + x - n + o
Sheet2.Cells(k, 1) = objsheet.Name
Next
Else
Sheet2.Cells(z + o, 1).Select
End If
If (z > 3 And insert_page = "Y") Then
If display_row_sheetname = "Y" Then
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=ActiveCell.Offset(-1, 0)
Else
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=ActiveCell
End If
End If
If ispastervalue = "Y" Then
Sheet2.Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Else
ActiveSheet.Paste
End If
z = z + x - n + 1 + insert_row + o
'將來源檔案關閉
'Windows(Filename).Close
i = i + 1 '讀取下一個檔案名稱
Sheet1.Activate
sheetname = Windows(Source).ActiveSheet.Range("b" & i)
Wend
End If
Windows(Source).Activate
Sheet2.Activate
With ActiveSheet
'.Columns.ColumnWidth = .StandardWidth
.Rows.RowHeight = 20
End With
Sheet2.Cells(1, 1).Select
'將來源檔案關閉
Workbooks(Filename).Saved = True
Windows(WorkName).Close
MsgBox "合併完畢,請按底下[工作表]切換回設[參數設定]"
|
