teratail
回答率
85.48%
質問するログイン新規登録
トップに関する質問つExcel.マクロ.VBお助けください。

編集履歴

質問編集履歴

15

追記

2016/06/16 01:04

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
@@ -1 +1 @@
1
- Excel.マクロ.VBお助けください。
1
+ つExcel.マクロ.VBお助けください。
test CHANGED
@@ -266,16 +266,174 @@
266
266
 
267
267
  追記３
268
268
 
269
+
270
+
271
+ このようなメッセージが出ました。
272
+
273
+ 隠れていたシートがありそこを指定していた間違いを修正しました。
274
+
275
+ ですが、追記２の部分が未だに謎のままです。
276
+
277
+ あと少しお力添えをお願いします。
278
+
279
+
280
+
281
+
282
+
283
+ ![イメージ説明](177e2cb34b71075bad98b875d50f56ed.png)
284
+
285
+
286
+
287
+ 追記４
288
+
289
+ マクロを起動すると取り込まれる側のエクセルデータが立ち上がるのですが自動的に消える処理まで到達していないことが分かりました。相変わらずデータの取得はできていません。原因解明の手口となればよいのですが…調べても原因解明に至っておりません。言葉足らずで頼ってばかりで申し訳ありませんがよろしくお願いします。
290
+
291
+
292
+
293
+ 追記５
294
+
295
+ ![イメージ説明](aed802fa53310b83cb737167136b085e.png)
296
+
297
+ ttyp03さん用
298
+
299
+
300
+
301
+ お礼
302
+
303
+
304
+
305
+ 皆さまのお力添えあって解決することができました！！！
306
+
307
+ ベストアンサーをお二方で悩みましたが
308
+
309
+ jawaさんとさせていただきます。
310
+
311
+ ttypさん、jawaさん本当にありがとうございました。
312
+
313
+
314
+
269
315
  ```
270
316
 
317
+ Option Explicit
318
+
319
+
320
+
321
+ Dim gyo As Long
322
+
323
+ Dim gyo2 As Long
324
+
325
+ Dim filecount As Long
326
+
327
+ Dim sheetcount As Long
328
+
329
+ Dim unmatch As Long
330
+
331
+ Dim erfilecount As Long
332
+
333
+ 'ボタンを押したとき
334
+
335
+ Sub FolderSelect()
336
+
337
+ ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
338
+
339
+ ThisWorkbook.Worksheets(2).Range("A3:BE3005").ClearContents
340
+
341
+ Dim folderpass As String
342
+
343
+ With Application.FileDialog(msoFileDialogFolderPicker)
344
+
345
+ If .Show = True Then
346
+
347
+ folderpass = .SelectedItems(1)
348
+
349
+ Else
350
+
351
+ ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
352
+
353
+ Exit Sub
354
+
355
+ End If
356
+
357
+ End With
358
+
359
+
360
+
361
+ filecount = 0
362
+
363
+ sheetcount = 0
364
+
365
+ unmatch = 0
366
+
367
+ erfilecount = 0
368
+
369
+ gyo = 6
370
+
371
+ gyo2 = 3
372
+
373
+
374
+
375
+ ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
376
+
377
+
378
+
379
+ Call FileSearch(folderpass, "*.xls*")
380
+
381
+ Dim dateupdate As String
382
+
383
+ dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
384
+
385
+ ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
386
+
387
+ ThisWorkbook.Worksheets(2).Name = dateupdate
388
+
389
+ ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
390
+
391
+ ThisWorkbook.Worksheets(2).Activate
392
+
393
+ End Sub
394
+
395
+ 'ファイル検索
396
+
397
+ Sub FileSearch(Path As String, Target As String)
398
+
399
+ Dim FSO As Object, Folder As Variant, File As Variant
400
+
401
+ Set FSO = CreateObject("Scripting.FileSystemObject")
402
+
403
+ For Each Folder In FSO.GetFolder(Path).SubFolders
404
+
405
+ Call FileSearch(Folder.Path, Target)
406
+
407
+ Next Folder
408
+
409
+ For Each File In FSO.GetFolder(Path).Files
410
+
411
+ If File.Name Like Target Then
412
+
413
+ filecount = filecount + 1
414
+
415
+ ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
416
+
417
+ ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
418
+
419
+ Call ParCopy(File.Path)
420
+
421
+ gyo = gyo + 1
422
+
423
+ End If
424
+
425
+ ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
426
+
427
+ Next File
428
+
429
+ End Sub
430
+
431
+ ''一覧出力
432
+
271
433
  Sub ParCopy(Path As String)
272
434
 
273
435
 
274
436
 
275
- 'Dim i As Long
276
-
277
- 'Dim j As Long
278
-
279
437
 
280
438
 
281
439
  Dim openbook As Workbook
@@ -294,25 +452,17 @@
294
452
 
295
453
 
296
454
 
297
- '一覧化コピペ
455
+
298
-
299
- 'For i = 1 To openbook.Worksheets.Count
300
456
 
301
457
 
302
458
 
303
459
  Set openbooksheet = openbook.Worksheets(1)
304
460
 
305
-
306
-
307
- 'Dim blof As Variant
461
+ openbooksheet.Unprotect
308
-
309
- 'ReDim blofar(0 To 1)
462
+
310
-
311
- 'For j = 0 To UBound(blof)
463
+
312
-
313
- ' blofar(j) = Trim(blof(j))
464
+
314
-
315
- 'Next j
465
+
316
466
 
317
467
 
318
468
 
@@ -352,33 +502,7 @@
352
502
 
353
503
 
354
504
 
355
- 'デバッグ用メッセージに書き出し
505
+
356
-
357
- strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
358
-
359
- strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
360
-
361
- strMsg = strMsg & "R2 :" & openbooksheet.Range("R2") & vbCr
362
-
363
- strMsg = strMsg & "AC43:" & openbooksheet.Range("AC43") & vbCr
364
-
365
- strMsg = strMsg & "AC44:" & openbooksheet.Range("AC44") & vbCr
366
-
367
- strMsg = strMsg & "AC45:" & openbooksheet.Range("AC45") & vbCr
368
-
369
- strMsg = strMsg & "AC46:" & openbooksheet.Range("AC46") & vbCr
370
-
371
- strMsg = strMsg & "AE48:" & openbooksheet.Range("AE48") & vbCr
372
-
373
- strMsg = strMsg & "AA2 :" & openbooksheet.Range("AA2") & vbCr
374
-
375
- strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
376
-
377
- strMsg = strMsg & "T22 :" & openbooksheet.Range("T22") & vbCr
378
-
379
- strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
380
-
381
-
382
506
 
383
507
  gyo2 = gyo2 + 1
384
508
 
@@ -386,15 +510,13 @@
386
510
 
387
511
 
388
512
 
389
- '処理中のファイル名・シート名を画面表示する
513
+
390
-
514
+
391
- Msgbox "ファイル名：" & Path & vbCr & "シート名：" & openbooksheet.Name & vbCr & strMsg
515
+ MsgBox "ファイル名：" & Path & vbCr & "シート名：" & openbooksheet.Name & vbCr & strMsg
392
-
393
-
394
-
395
- 'Next i
516
+
396
-
397
-
517
+
518
+
519
+
398
520
 
399
521
  openbook.Close False
400
522
 
@@ -406,6 +528,8 @@
406
528
 
407
529
  myError:
408
530
 
531
+ MsgBox Err.Description
532
+
409
533
  ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
410
534
 
411
535
  erfilecount = erfilecount + 1
@@ -416,46 +540,6 @@
416
540
 
417
541
  ```
418
542
 
419
- このソースを使用して起動すると
420
-
421
- このようなメッセージが出ました。
543
+ 同じような躓き方をする方がいましたら使ってください。
422
-
423
- 隠れていたシートがありそこを指定していた間違いを修正しました。
544
+
424
-
425
- ですが、追記２の部分が未だに謎のままです。
426
-
427
- あと少しお力添えをお願いします。
545
+ 現在動いている最終形態です。
428
-
429
-
430
-
431
-
432
-
433
- ![イメージ説明](177e2cb34b71075bad98b875d50f56ed.png)
434
-
435
-
436
-
437
- 追記４
438
-
439
- マクロを起動すると取り込まれる側のエクセルデータが立ち上がるのですが自動的に消える処理まで到達していないことが分かりました。相変わらずデータの取得はできていません。原因解明の手口となればよいのですが…調べても原因解明に至っておりません。言葉足らずで頼ってばかりで申し訳ありませんがよろしくお願いします。
440
-
441
-
442
-
443
- 追記５
444
-
445
- ![イメージ説明](aed802fa53310b83cb737167136b085e.png)
446
-
447
- ttyp03さん用
448
-
449
-
450
-
451
- お礼
452
-
453
-
454
-
455
- 皆さまのお力添えあって解決することができました！！！
456
-
457
- ベストアンサーをお二方で悩みましたが
458
-
459
- jawaさんとさせていただきます。
460
-
461
- ttypさん、jawaさん本当にありがとうございました。

14

お礼

2016/06/16 01:04

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -445,3 +445,17 @@
445
445
  ![イメージ説明](aed802fa53310b83cb737167136b085e.png)
446
446
 
447
447
  ttyp03さん用
448
+
449
+
450
+
451
+ お礼
452
+
453
+
454
+
455
+ 皆さまのお力添えあって解決することができました！！！
456
+
457
+ ベストアンサーをお二方で悩みましたが
458
+
459
+ jawaさんとさせていただきます。
460
+
461
+ ttypさん、jawaさん本当にありがとうございました。

13

追記5

2016/06/16 01:01

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -437,3 +437,11 @@
437
437
  追記４
438
438
 
439
439
  マクロを起動すると取り込まれる側のエクセルデータが立ち上がるのですが自動的に消える処理まで到達していないことが分かりました。相変わらずデータの取得はできていません。原因解明の手口となればよいのですが…調べても原因解明に至っておりません。言葉足らずで頼ってばかりで申し訳ありませんがよろしくお願いします。
440
+
441
+
442
+
443
+ 追記５
444
+
445
+ ![イメージ説明](aed802fa53310b83cb737167136b085e.png)
446
+
447
+ ttyp03さん用

12

追記４

2016/06/15 08:09

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -431,3 +431,9 @@
431
431
 
432
432
 
433
433
  ![イメージ説明](177e2cb34b71075bad98b875d50f56ed.png)
434
+
435
+
436
+
437
+ 追記４
438
+
439
+ マクロを起動すると取り込まれる側のエクセルデータが立ち上がるのですが自動的に消える処理まで到達していないことが分かりました。相変わらずデータの取得はできていません。原因解明の手口となればよいのですが…調べても原因解明に至っておりません。言葉足らずで頼ってばかりで申し訳ありませんがよろしくお願いします。

11

追記

2016/06/15 07:47

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -254,7 +254,7 @@
254
254
 
255
255
  1シート目のタイトルは出てくるのですが、2シート目の集計シートに指定したセルのデータがなぜか入らないという状況です。よろしくお願いします。
256
256
 
257
- 追記
257
+ 追記２
258
258
 
259
259
  どこまでデータが上書きされるのか確認するために
260
260
 
@@ -264,6 +264,8 @@
264
264
 
265
265
  46-57(AT-BE)は値が入ったままになっています。
266
266
 
267
+ 追記３
268
+
267
269
  ```
268
270
 
269
271
  Sub ParCopy(Path As String)
@@ -418,4 +420,14 @@
418
420
 
419
421
  このようなメッセージが出ました。
420
422
 
423
+ 隠れていたシートがありそこを指定していた間違いを修正しました。
424
+
425
+ ですが、追記２の部分が未だに謎のままです。
426
+
427
+ あと少しお力添えをお願いします。
428
+
429
+
430
+
431
+
432
+
421
433
  ![イメージ説明](177e2cb34b71075bad98b875d50f56ed.png)

10

追記

2016/06/15 01:58

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -264,4 +264,158 @@
264
264
 
265
265
  46-57(AT-BE)は値が入ったままになっています。
266
266
 
267
+ ```
268
+
269
+ Sub ParCopy(Path As String)
270
+
271
+
272
+
273
+ 'Dim i As Long
274
+
275
+ 'Dim j As Long
276
+
277
+
278
+
279
+ Dim openbook As Workbook
280
+
281
+ Dim openbooksheet As Worksheet
282
+
283
+
284
+
285
+ Application.ScreenUpdating = False
286
+
287
+
288
+
289
+ On Error GoTo myError
290
+
291
+ Set openbook = Application.Workbooks.Open(Path)
292
+
293
+
294
+
295
+ '一覧化コピペ
296
+
297
+ 'For i = 1 To openbook.Worksheets.Count
298
+
299
+
300
+
301
+ Set openbooksheet = openbook.Worksheets(1)
302
+
303
+
304
+
305
+ 'Dim blof As Variant
306
+
307
+ 'ReDim blofar(0 To 1)
308
+
309
+ 'For j = 0 To UBound(blof)
310
+
311
+ ' blofar(j) = Trim(blof(j))
312
+
313
+ 'Next j
314
+
315
+
316
+
317
+ Dim strMsg As String 'デバッグ用メッセージ
318
+
319
+ strMsg = ""
320
+
321
+
322
+
323
+ If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> 1 Then
324
+
325
+ 'シートに書き出し
326
+
327
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")
328
+
329
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 7) = openbooksheet.Range("A70")
330
+
331
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 42) = openbooksheet.Range("R2")
332
+
333
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 43) = openbooksheet.Range("AC43")
334
+
335
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 44) = openbooksheet.Range("AC44")
336
+
337
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 45) = openbooksheet.Range("AC45")
338
+
339
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 46) = openbooksheet.Range("AC46")
340
+
341
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 47) = openbooksheet.Range("AE48")
342
+
343
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 49) = openbooksheet.Range("AA2")
344
+
345
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 52) = openbooksheet.Range("M22")
346
+
347
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 54) = openbooksheet.Range("T22")
348
+
349
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 56) = openbooksheet.Range("M22")
350
+
351
+
352
+
353
+ 'デバッグ用メッセージに書き出し
354
+
355
+ strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
356
+
357
+ strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
358
+
359
+ strMsg = strMsg & "R2 :" & openbooksheet.Range("R2") & vbCr
360
+
361
+ strMsg = strMsg & "AC43:" & openbooksheet.Range("AC43") & vbCr
362
+
363
+ strMsg = strMsg & "AC44:" & openbooksheet.Range("AC44") & vbCr
364
+
365
+ strMsg = strMsg & "AC45:" & openbooksheet.Range("AC45") & vbCr
366
+
367
+ strMsg = strMsg & "AC46:" & openbooksheet.Range("AC46") & vbCr
368
+
369
+ strMsg = strMsg & "AE48:" & openbooksheet.Range("AE48") & vbCr
370
+
371
+ strMsg = strMsg & "AA2 :" & openbooksheet.Range("AA2") & vbCr
372
+
373
+ strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
374
+
375
+ strMsg = strMsg & "T22 :" & openbooksheet.Range("T22") & vbCr
376
+
377
+ strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
378
+
379
+
380
+
381
+ gyo2 = gyo2 + 1
382
+
383
+ End If
384
+
385
+
386
+
387
+ '処理中のファイル名・シート名を画面表示する
388
+
389
+ Msgbox "ファイル名：" & Path & vbCr & "シート名：" & openbooksheet.Name & vbCr & strMsg
390
+
391
+
392
+
393
+ 'Next i
394
+
395
+
396
+
397
+ openbook.Close False
398
+
399
+
400
+
401
+ Application.ScreenUpdating = True
402
+
403
+ Exit Sub
404
+
405
+ myError:
406
+
407
+ ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
408
+
409
+ erfilecount = erfilecount + 1
410
+
411
+ Application.ScreenUpdating = True
412
+
413
+ End Sub
414
+
415
+ ```
416
+
417
+ このソースを使用して起動すると
418
+
419
+ このようなメッセージが出ました。
420
+
267
421
  ![イメージ説明](177e2cb34b71075bad98b875d50f56ed.png)

9

追記

2016/06/15 00:44

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -263,3 +263,5 @@
263
263
  1-45(A-AS)は空白に書き換わり
264
264
 
265
265
  46-57(AT-BE)は値が入ったままになっています。
266
+
267
+ ![イメージ説明](177e2cb34b71075bad98b875d50f56ed.png)

8

追記

2016/06/15 00:41

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -253,3 +253,13 @@
253
253
  取り込む側のシート構成は１シート目に取り込んだデータのタイトルが並ぶ役割を、2シート目には指定したデータを集計する欄を作ってあります。
254
254
 
255
255
  1シート目のタイトルは出てくるのですが、2シート目の集計シートに指定したセルのデータがなぜか入らないという状況です。よろしくお願いします。
256
+
257
+ 追記
258
+
259
+ どこまでデータが上書きされるのか確認するために
260
+
261
+ 1-57(A-BE)に適当な値を入れてマクロを起動すると
262
+
263
+ 1-45(A-AS)は空白に書き換わり
264
+
265
+ 46-57(AT-BE)は値が入ったままになっています。

7

仕様の追記

2016/06/14 08:42

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -243,3 +243,13 @@
243
243
  初心者で言葉足らずですが、ここはいらない、ここが足りない等お言葉を下さい。
244
244
 
245
245
  よろしくお願いします。
246
+
247
+ 追記
248
+
249
+ あまりにも言葉足らずでしたので追記します。
250
+
251
+ 複数個のデータ（1シート目に取り込みたいデータがある）が入ったフォルダ（取り込まれる側）を選択し、取り込む側の2シート目に出力すというマクロです。
252
+
253
+ 取り込む側のシート構成は１シート目に取り込んだデータのタイトルが並ぶ役割を、2シート目には指定したデータを集計する欄を作ってあります。
254
+
255
+ 1シート目のタイトルは出てくるのですが、2シート目の集計シートに指定したセルのデータがなぜか入らないという状況です。よろしくお願いします。

6

。

2016/06/14 06:33

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -32,218 +32,202 @@
32
32
 
33
33
  Dim erfilecount As Long
34
34
 
35
+ 'ボタンを押したとき
36
+
37
+ Sub FolderSelect()
38
+
39
+ ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
40
+
41
+ ThisWorkbook.Worksheets(2).Range("A3:AS3005").ClearContents
42
+
43
+ Dim folderpass As String
44
+
45
+ With Application.FileDialog(msoFileDialogFolderPicker)
46
+
47
+ If .Show = True Then
48
+
49
+ folderpass = .SelectedItems(1)
50
+
51
+ Else
52
+
53
+ ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
54
+
55
+ Exit Sub
56
+
57
+ End If
58
+
59
+ End With
60
+
61
+
62
+
63
+ filecount = 0
64
+
65
+ sheetcount = 0
66
+
67
+ unmatch = 0
68
+
69
+ erfilecount = 0
70
+
71
+ gyo = 6
72
+
73
+ gyo2 = 3
74
+
75
+
76
+
77
+ ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
78
+
79
+
80
+
81
+ Call FileSearch(folderpass, "*.xls*")
82
+
83
+ Dim dateupdate As String
84
+
85
+ dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
86
+
87
+ ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
88
+
89
+ ThisWorkbook.Worksheets(2).Name = dateupdate
90
+
91
+ ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
92
+
93
+ ThisWorkbook.Worksheets(2).Activate
94
+
95
+ End Sub
96
+
97
+ 'ファイル検索
98
+
99
+ Sub FileSearch(Path As String, Target As String)
100
+
101
+ Dim FSO As Object, Folder As Variant, File As Variant
102
+
103
+ Set FSO = CreateObject("Scripting.FileSystemObject")
104
+
105
+ For Each Folder In FSO.GetFolder(Path).SubFolders
106
+
107
+ Call FileSearch(Folder.Path, Target)
108
+
109
+ Next Folder
110
+
111
+ For Each File In FSO.GetFolder(Path).Files
112
+
113
+ If File.Name Like Target Then
114
+
115
+ filecount = filecount + 1
116
+
117
+ ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
118
+
119
+ ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
120
+
121
+ Call ParCopy(File.Path)
122
+
123
+ gyo = gyo + 1
124
+
125
+ End If
126
+
127
+ ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
128
+
129
+ Next File
130
+
131
+ End Sub
132
+
133
+ ''一覧出力
134
+
135
+ Sub ParCopy(Path As String)
136
+
137
+ Dim i As Long
138
+
139
+ Dim j As Long
140
+
141
+ Dim openbook As Workbook
142
+
143
+ Dim openbooksheet As Worksheet
144
+
145
+ Application.ScreenUpdating = False
146
+
147
+ On Error GoTo myError
148
+
149
+ Set openbook = Application.Workbooks.Open(Path)
150
+
151
+ '一覧化コピペ
152
+
153
+ For i = 1 To openbook.Worksheets.Count
154
+
155
+ Set openbooksheet = openbook.Worksheets(1)
156
+
157
+ Dim blof As Variant
158
+
159
+ ReDim blofar(0 To 1)
160
+
161
+ For j = 0 To UBound(blof)
162
+
163
+ blofar(j) = Trim(blof(j))
164
+
165
+ Next j
166
+
167
+ If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> "1" Then
168
+
169
+
170
+
171
+
172
+
173
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")
174
+
175
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 7) = openbooksheet.Range("A70")
176
+
177
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 42) = openbooksheet.Range("R2")
178
+
179
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 43) = openbooksheet.Range("AC43")
180
+
181
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 44) = openbooksheet.Range("AC44")
182
+
183
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 45) = openbooksheet.Range("AC45")
184
+
185
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 46) = openbooksheet.Range("AC46")
186
+
187
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 47) = openbooksheet.Range("AE48")
188
+
189
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 49) = openbooksheet.Range("AA2")
190
+
191
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 52) = openbooksheet.Range("M22")
192
+
193
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 54) = openbooksheet.Range("T22")
194
+
195
+ ThisWorkbook.Worksheets(2).Cells(gyo2, 56) = openbooksheet.Range("M22")
196
+
197
+
198
+
199
+
200
+
201
+
202
+
203
+ gyo2 = gyo2 + 1
204
+
205
+ End If
206
+
207
+
208
+
209
+ Next i
210
+
211
+
212
+
213
+ openbook.Close False
214
+
215
+ Application.ScreenUpdating = True
216
+
217
+ Exit Sub
218
+
219
+ myError:
220
+
221
+ ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
222
+
223
+ erfilecount = erfilecount + 1
224
+
225
+ Application.ScreenUpdating = True
226
+
227
+ End Sub
228
+
35
229
  ```
36
230
 
37
- ```
38
-
39
- 'ボタンを押したとき
40
-
41
- Sub FolderSelect()
42
-
43
- ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
44
-
45
- ThisWorkbook.Worksheets(2).Range("A3:AS3005").ClearContents
46
-
47
- Dim folderpass As String
48
-
49
- With Application.FileDialog(msoFileDialogFolderPicker)
50
-
51
- If .Show = True Then
52
-
53
- folderpass = .SelectedItems(1)
54
-
55
- Else
56
-
57
- ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
58
-
59
- Exit Sub
60
-
61
- End If
62
-
63
- End With
64
-
65
-
66
-
67
- filecount = 0
68
-
69
- sheetcount = 0
70
-
71
- unmatch = 0
72
-
73
- erfilecount = 0
74
-
75
- gyo = 6
76
-
77
- gyo2 = 3
78
-
79
-
80
-
81
- ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
82
-
83
-
84
-
85
- Call FileSearch(folderpass, "*.xls*")
86
-
87
- Dim dateupdate As String
88
-
89
- dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
90
-
91
- ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
92
-
93
- ThisWorkbook.Worksheets(2).Name = dateupdate
94
-
95
- ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
96
-
97
- ThisWorkbook.Worksheets(2).Activate
98
-
99
- End Sub
100
-
101
- ```
102
-
103
- ```
104
-
105
- 'ファイル検索
106
-
107
- Sub FileSearch(Path As String, Target As String)
108
-
109
- Dim FSO As Object, Folder As Variant, File As Variant
110
-
111
- Set FSO = CreateObject("Scripting.FileSystemObject")
112
-
113
- For Each Folder In FSO.GetFolder(Path).SubFolders
114
-
115
- Call FileSearch(Folder.Path, Target)
116
-
117
- Next Folder
118
-
119
- For Each File In FSO.GetFolder(Path).Files
120
-
121
- If File.Name Like Target Then
122
-
123
- filecount = filecount + 1
124
-
125
- ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
126
-
127
- ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
128
-
129
- Call ParCopy(File.Path)
130
-
131
- gyo = gyo + 1
132
-
133
- End If
134
-
135
- ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
136
-
137
- Next File
138
-
139
- End Sub
140
-
141
- ```
142
-
143
- ```
144
-
145
- ''一覧出力
146
-
147
- Sub ParCopy(Path As String)
148
-
149
- Dim i As Long
150
-
151
- Dim j As Long
152
-
153
- Dim openbook As Workbook
154
-
155
- Dim openbooksheet As Worksheet
156
-
157
- Application.ScreenUpdating = False
158
-
159
- On Error GoTo myError
160
-
161
- Set openbook = Application.Workbooks.Open(Path)
162
-
163
- ```
164
-
165
- ```
166
-
167
- '一覧化コピペ
168
-
169
- For i = 1 To openbook.Worksheets.Count
170
-
171
- Set openbooksheet = openbook.Worksheets(1)
172
-
173
- Dim blof As Variant
174
-
175
- ReDim blofar(0 To 1)
176
-
177
- For j = 0 To UBound(blof)
178
-
179
- blofar(j) = Trim(blof(j))
180
-
181
- Next j
182
-
183
- If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> "1" Then
184
-
185
-
186
-
187
-
188
-
189
- ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")
190
-
191
- ThisWorkbook.Worksheets(2).Cells(gyo2, 7) = openbooksheet.Range("A70")
192
-
193
- ThisWorkbook.Worksheets(2).Cells(gyo2, 42) = openbooksheet.Range("R2")
194
-
195
- ThisWorkbook.Worksheets(2).Cells(gyo2, 43) = openbooksheet.Range("AC43")
196
-
197
- ThisWorkbook.Worksheets(2).Cells(gyo2, 44) = openbooksheet.Range("AC44")
198
-
199
- ThisWorkbook.Worksheets(2).Cells(gyo2, 45) = openbooksheet.Range("AC45")
200
-
201
- ThisWorkbook.Worksheets(2).Cells(gyo2, 46) = openbooksheet.Range("AC46")
202
-
203
- ThisWorkbook.Worksheets(2).Cells(gyo2, 47) = openbooksheet.Range("AE48")
204
-
205
- ThisWorkbook.Worksheets(2).Cells(gyo2, 49) = openbooksheet.Range("AA2")
206
-
207
- ThisWorkbook.Worksheets(2).Cells(gyo2, 52) = openbooksheet.Range("M22")
208
-
209
- ThisWorkbook.Worksheets(2).Cells(gyo2, 54) = openbooksheet.Range("T22")
210
-
211
- ThisWorkbook.Worksheets(2).Cells(gyo2, 56) = openbooksheet.Range("M22")
212
-
213
-
214
-
215
-
216
-
217
-
218
-
219
- gyo2 = gyo2 + 1
220
-
221
- End If
222
-
223
-
224
-
225
- Next i
226
-
227
-
228
-
229
- openbook.Close False
230
-
231
- Application.ScreenUpdating = True
232
-
233
- Exit Sub
234
-
235
- myError:
236
-
237
- ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
238
-
239
- erfilecount = erfilecount + 1
240
-
241
- Application.ScreenUpdating = True
242
-
243
- End Sub
244
-
245
- ```
246
-
247
231
 
248
232
 
249
233
 

5

VV

2016/06/14 04:12

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -34,6 +34,8 @@
34
34
 
35
35
  ```
36
36
 
37
+ ```
38
+
37
39
  'ボタンを押したとき
38
40
 
39
41
  Sub FolderSelect()
@@ -98,6 +100,8 @@
98
100
 
99
101
  ```
100
102
 
103
+ ```
104
+
101
105
  'ファイル検索
102
106
 
103
107
  Sub FileSearch(Path As String, Target As String)
@@ -136,6 +140,8 @@
136
140
 
137
141
  ```
138
142
 
143
+ ```
144
+
139
145
  ''一覧出力
140
146
 
141
147
  Sub ParCopy(Path As String)
@@ -154,6 +160,8 @@
154
160
 
155
161
  Set openbook = Application.Workbooks.Open(Path)
156
162
 
163
+ ```
164
+
157
165
  ```
158
166
 
159
167
  '一覧化コピペ

4

```

2016/06/14 04:08

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -14,7 +14,7 @@
14
14
 
15
15
  ソースがこちらです。
16
16
 
17
- '''
17
+ ```
18
18
 
19
19
  Option Explicit
20
20
 
@@ -32,7 +32,7 @@
32
32
 
33
33
  Dim erfilecount As Long
34
34
 
35
- '''
35
+ ```
36
36
 
37
37
  'ボタンを押したとき
38
38
 
@@ -96,7 +96,7 @@
96
96
 
97
97
  End Sub
98
98
 
99
- '''
99
+ ```
100
100
 
101
101
  'ファイル検索
102
102
 
@@ -134,7 +134,7 @@
134
134
 
135
135
  End Sub
136
136
 
137
- '''
137
+ ```
138
138
 
139
139
  ''一覧出力
140
140
 
@@ -154,7 +154,7 @@
154
154
 
155
155
  Set openbook = Application.Workbooks.Open(Path)
156
156
 
157
- '''
157
+ ```
158
158
 
159
159
  '一覧化コピペ
160
160
 
@@ -234,7 +234,7 @@
234
234
 
235
235
  End Sub
236
236
 
237
- '''
237
+ ```
238
238
 
239
239
 
240
240
 

3

'

2016/06/14 04:06

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -32,7 +32,7 @@
32
32
 
33
33
  Dim erfilecount As Long
34
34
 
35
-
35
+ '''
36
36
 
37
37
  'ボタンを押したとき
38
38
 
@@ -96,6 +96,8 @@
96
96
 
97
97
  End Sub
98
98
 
99
+ '''
100
+
99
101
  'ファイル検索
100
102
 
101
103
  Sub FileSearch(Path As String, Target As String)
@@ -132,6 +134,8 @@
132
134
 
133
135
  End Sub
134
136
 
137
+ '''
138
+
135
139
  ''一覧出力
136
140
 
137
141
  Sub ParCopy(Path As String)
@@ -150,7 +154,7 @@
150
154
 
151
155
  Set openbook = Application.Workbooks.Open(Path)
152
156
 
153
-
157
+ '''
154
158
 
155
159
  '一覧化コピペ
156
160
 

2

シングルコーテーションでソースを囲みました。

2016/06/14 04:05

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -14,6 +14,8 @@
14
14
 
15
15
  ソースがこちらです。
16
16
 
17
+ '''
18
+
17
19
  Option Explicit
18
20
 
19
21
 
@@ -228,7 +230,7 @@
228
230
 
229
231
  End Sub
230
232
 
231
-
233
+ '''
232
234
 
233
235
 
234
236
 

1

テンプレートのシングルコーテーションが紛らわしいので消しました。

2016/06/14 04:03

投稿

teryyyyy2
teryyyyy2

スコア17

test CHANGED
File without changes
test CHANGED
@@ -4,13 +4,13 @@
4
4
 
5
5
 
6
6
 
7
- ```
7
+
8
8
 
9
9
  途中までは動いているのですが指定した個所の値ではなく、
10
10
 
11
11
  なぜか空白になってしまっています。
12
12
 
13
- ```
13
+
14
14
 
15
15
  ソースがこちらです。
16
16
 
@@ -232,8 +232,6 @@
232
232
 
233
233
 
234
234
 
235
- ```
236
-
237
235
 
238
236
 
239
237
  どこまで動いているか確認するために