質問編集履歴

3

ループエラー箇所を特定しました。

2019/02/27 03:08

投稿

SugiuraY
SugiuraY

score311

test CHANGED
File without changes
test CHANGED
@@ -185,3 +185,119 @@
185
185
  End Sub
186
186
 
187
187
  ```
188
+
189
+
190
+
191
+ 再修正コード
192
+
193
+ ```vba
194
+
195
+ Sub fileOpenAndCreate()
196
+
197
+ Dim fileName As String
198
+
199
+ Dim r As Long
200
+
201
+ Dim oldPath As String
202
+
203
+ Dim newPath As String
204
+
205
+
206
+
207
+ Dim nWb As Workbook
208
+
209
+ Dim oWb As Workbook
210
+
211
+ Dim oWs As Worksheet
212
+
213
+ Dim tWs As Worksheet
214
+
215
+ Dim nWs As Worksheet
216
+
217
+ Dim nWsTf As Worksheet
218
+
219
+
220
+
221
+
222
+
223
+ Set tWs = Worksheets("実行シート")
224
+
225
+
226
+
227
+ r = 2
228
+
229
+ While tWs.Cells(r, 1) <> ""
230
+
231
+
232
+
233
+ oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
234
+
235
+ newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
236
+
237
+
238
+
239
+
240
+
241
+ Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認
242
+
243
+ Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value)
244
+
245
+ MsgBox "Doesnt work" & r '↑ここでインデックスエラー
246
+
247
+ 'new------------
248
+
249
+
250
+
251
+
252
+
253
+ Set nWb = Workbooks.Add
254
+
255
+ Set nWs = nWb.Worksheets("Sheet1")
256
+
257
+ oWs.Copy After:=nWs
258
+
259
+
260
+
261
+ Application.DisplayAlerts = False
262
+
263
+ nWs.Delete
264
+
265
+ Application.DisplayAlerts = True
266
+
267
+
268
+
269
+ 'new tf------------
270
+
271
+ Set nWsTf = nWb.Worksheets(tWs.Cells(r, 2).Value)
272
+
273
+ nWsTf.Cells.Font.Name = "MS Pゴシック"
274
+
275
+
276
+
277
+
278
+
279
+ nWb.SaveAs (newPath)
280
+
281
+
282
+
283
+
284
+
285
+ r = r + 1
286
+
287
+ Wend
288
+
289
+
290
+
291
+
292
+
293
+
294
+
295
+ End Sub
296
+
297
+
298
+
299
+
300
+
301
+
302
+
303
+ ```

2

訂正

2019/02/27 03:08

投稿

SugiuraY
SugiuraY

score311

test CHANGED
File without changes
test CHANGED
@@ -138,9 +138,9 @@
138
138
 
139
139
  While Cells(r, 1) <> ""
140
140
 
141
- oldPath = "C:\Users\regawa\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
141
+ oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
142
142
 
143
- newPath = "C:\Users\regawa\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
143
+ newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
144
144
 
145
145
 
146
146
 

1

明示したコードに修正しました。

2019/02/27 01:34

投稿

SugiuraY
SugiuraY

score311

test CHANGED
File without changes
test CHANGED
@@ -95,3 +95,93 @@
95
95
  End Sub
96
96
 
97
97
  ```
98
+
99
+
100
+
101
+
102
+
103
+ 修正後のコード
104
+
105
+ ```vba
106
+
107
+ Sub fileOpenAndCreate()
108
+
109
+ Dim fileName As String
110
+
111
+ Dim r As Long
112
+
113
+ Dim oldPath As String
114
+
115
+ Dim newPath As String
116
+
117
+
118
+
119
+ Dim nWb As Workbook
120
+
121
+ Dim oWb As Workbook
122
+
123
+ Dim oWs As Worksheet
124
+
125
+ Dim tWs As Worksheet
126
+
127
+ Dim nWs As Worksheet
128
+
129
+
130
+
131
+
132
+
133
+ Set tWs = Worksheets("実行シート")
134
+
135
+
136
+
137
+ r = 2
138
+
139
+ While Cells(r, 1) <> ""
140
+
141
+ oldPath = "C:\Users\regawa\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
142
+
143
+ newPath = "C:\Users\regawa\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
144
+
145
+
146
+
147
+ 'old------------
148
+
149
+ Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認
150
+
151
+ Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value)
152
+
153
+
154
+
155
+ 'new------------
156
+
157
+ Set nWb = Workbooks.Add
158
+
159
+ nWb.SaveAs (newPath)
160
+
161
+ Set nWs = nWb.Worksheets(1)
162
+
163
+ nWs.Name = tWs.Cells(r, 2).Value
164
+
165
+
166
+
167
+
168
+
169
+ oWs.Copy After:=nWs(tWs.Cells(r, 2).Value)
170
+
171
+
172
+
173
+
174
+
175
+ r = r + 1
176
+
177
+ Wend
178
+
179
+
180
+
181
+
182
+
183
+
184
+
185
+ End Sub
186
+
187
+ ```