teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップに関する質問VBA　再帰　終わらない

編集履歴

質問編集履歴

1

ｊｊｊ

2020/09/01 08:44

投稿

yakumo02
yakumo02

スコア103

test CHANGED
File without changes
test CHANGED
@@ -81,3 +81,219 @@
81
81
  End Sub
82
82
 
83
83
  ```
84
+
85
+
86
+
87
+
88
+
89
+ hikaku
90
+
91
+ ```
92
+
93
+ Sub hikaku()
94
+
95
+ If bb > 0 Then
96
+
97
+
98
+
99
+ Do While UBound(Sheet) >= b
100
+
101
+
102
+
103
+ Application.ScreenUpdating = False
104
+
105
+ my = Sheet_path(b)
106
+
107
+
108
+
109
+ Filename = Dir(my & "\" & "*test.xls*")
110
+
111
+
112
+
113
+ Set open_file = Workbooks.Open(Filename:=my & "\" & Filename, UpdateLinks:=False)
114
+
115
+ Set target_sheet = Workbooks(Filename).Worksheets("画面")
116
+
117
+ Set target_sheet2 = ThisWorkbook.Worksheets("画面")
118
+
119
+ MaxRow = target_sheet.Cells(Rows.Count, 2).End(xlUp).Row
120
+
121
+
122
+
123
+
124
+
125
+ ReDim screen(1, 1 To MaxRow)
126
+
127
+ ReDim Number(1, 1 To MaxRow)
128
+
129
+ ReDim Lavel(1, 1 To MaxRow)
130
+
131
+ ReDim Project_type(1, 1 To MaxRow)
132
+
133
+ ReDim Control(1, 1 To MaxRow)
134
+
135
+ ReDim Events(1, 1 To MaxRow)
136
+
137
+ ReDim Sort(1, 1 To MaxRow)
138
+
139
+ ReDim Lifting(1, 1 To MaxRow)
140
+
141
+ ReDim Erea(1, 1 To MaxRow)
142
+
143
+
144
+
145
+ C = 1
146
+
147
+ d = 1
148
+
149
+ h = 1
150
+
151
+
152
+
153
+
154
+
155
+ For i = 1 To UBound(screen, 1)
156
+
157
+
158
+
159
+ For f = 1 To MaxRow
160
+
161
+
162
+
163
+ If WorksheetFunction.IsNumber(target_sheet.Cells(d, 2).Value) = True And Not target_sheet.Cells(d, 2).Value = "" Then
164
+
165
+
166
+
167
+ screen(i, h) = target_sheet.Cells(d, 4)
168
+
169
+ Number(i, h) = target_sheet.Cells(d, 2)
170
+
171
+ Lavel(i, h) = target_sheet.Cells(d, 14)
172
+
173
+ Project_type(i, h) = target_sheet.Cells(d, 10)
174
+
175
+ Control(i, h) = target_sheet.Cells(d, 32)
176
+
177
+ Events(i, h) = target_sheet.Cells(d, 81)
178
+
179
+ Sort(i, h) = target_sheet.Cells(d, 85)
180
+
181
+ Lifting(i, h) = target_sheet.Cells(d, 87)
182
+
183
+
184
+
185
+ h = h + 1
186
+
187
+ End If
188
+
189
+
190
+
191
+ If TypeName(target_sheet.Cells(d, 2).Value) = "String" Then
192
+
193
+ Erea(i, C) = target_sheet.Cells(d, 2)
194
+
195
+ C = C + 1
196
+
197
+ End If
198
+
199
+
200
+
201
+ d = d + 1
202
+
203
+
204
+
205
+ Next f
206
+
207
+ Next i
208
+
209
+
210
+
211
+
212
+
213
+
214
+
215
+ d = MaxRow
216
+
217
+
218
+
219
+ Do While h > 1
220
+
221
+
222
+
223
+ If TypeName(target_sheet.Cells(d, 2).Value) = "String" Then
224
+
225
+ C = C - 1
226
+
227
+
228
+
229
+ ElseIf WorksheetFunction.IsNumber(target_sheet.Cells(d, 2).Value) = True Then
230
+
231
+
232
+
233
+ ThisWorkbook.Worksheets(1).Range("A2:L2").Insert
234
+
235
+ target_sheet2.Cells(2, 6) = CStr(screen(1, h - 1))
236
+
237
+ target_sheet2.Cells(2, 2) = Workbooks(Filename).Worksheets("???").Cells(16, 25)
238
+
239
+ target_sheet2.Cells(2, 3) = Workbooks(Filename).Worksheets("???").Cells(17, 25)
240
+
241
+ target_sheet2.Cells(2, 5) = Number(1, h - 1)
242
+
243
+ target_sheet2.Cells(2, 7) = CStr(Lavel(1, h - 1))
244
+
245
+ target_sheet2.Cells(2, 8) = CStr(Project_type(1, h - 1))
246
+
247
+ target_sheet2.Cells(2, 9) = CStr(Control(1, h - 1))
248
+
249
+ target_sheet2.Cells(2, 10) = CStr(Events(1, h - 1))
250
+
251
+ target_sheet2.Cells(2, 11) = Sort(1, h - 1)
252
+
253
+ target_sheet2.Cells(2, 12) = Lifting(1, h - 1)
254
+
255
+ target_sheet2.Cells(2, 4) = Erea(1, C - 1) 'koko
256
+
257
+ ThisWorkbook.Worksheets(1).Range("A2:L2").ClearFormats
258
+
259
+ h = h - 1
260
+
261
+
262
+
263
+ End If
264
+
265
+
266
+
267
+ d = d - 1
268
+
269
+
270
+
271
+ Loop
272
+
273
+
274
+
275
+
276
+
277
+ Workbooks(Filename).Close
278
+
279
+ Application.ScreenUpdating = True
280
+
281
+ b = b + 1
282
+
283
+ Loop
284
+
285
+
286
+
287
+ Else
288
+
289
+ MsgBox "なし"
290
+
291
+ End
292
+
293
+ End If
294
+
295
+
296
+
297
+ End Sub
298
+
299
+ ```