Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


18271 / 76738 ←次へ | 前へ→

【63910】Re:マクロを早く快適に動かしたいです
発言  かみちゃん  - 09/12/31(木) 10:40 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>なんとか早くするにはどうしたらよいものでしょうか?

Excelのバージョンは2007でしょうか?
できれば、バージョンも書いておいていただいたほうがいいかと思います。

提示されたコードは、インデントがないので、少し修正をさせていただきました。
以下のようなコードで見易さについてどのようにお感じになりますでしょうか?

その上で、処理の先頭で、再計算モードを手動にして、処理の最後で自動に戻す
ようにしてはいかがでしょうか?
具体的には、★の行の記述です。

なお、コードがExcel2007のようで、当方では環境がないので、検証はしていません。

Sub 月間データ統合()
 Dim dataFolder As String
 Dim tmpSheet As Worksheet
 Dim subFolder As String
 Dim lastRow As Long
 Dim fileName As String
 Dim R As Long
 Dim i As Long
 Dim isOpen As Boolean
 Dim book As Workbook
 Dim csv As Workbook
   
 Dim ws As Worksheet
 Dim wsT As Worksheet
 Dim Ranges() As String, N As Long
 
 Application.ScreenUpdating = False
 Application.Calculation = xlManual '★
  
 dataFolder = "C:\Documents and Settings\月間データ統合" 'データフォルダ
 Set tmpSheet = Sheets("Sheet1") '作業シート
 tmpSheet.Cells.Clear '作業シートクリア
 'フォルダ名取得
 R = 1 '出力行の初期値
 subFolder = Dir(dataFolder & "\", vbDirectory) 'データフォルダ内のフォルダとファイルを取得
 Do While subFolder <> "" 'なくなるまで
  If (GetAttr(dataFolder & "\" & subFolder) And vbDirectory) = vbDirectory Then 'ディレクトリで
   If subFolder <> "." And subFolder <> ".." Then ' 現在のフォルダと親フォルダでなければ
    tmpSheet.Range("A" & R) = subFolder '作業シートのA列にフォルダ名を表示
    R = R + 1 '出力行+1
   End If
  End If
  subFolder = Dir '次のフォルダ名を取得
 Loop
 'csvファイル名取得
 lastRow = tmpSheet.Range("A" & Rows.Count).End(xlUp).Row '作業シートのA列の最終行
 R = 1 '出力行の初期値
 For i = 1 To lastRow
  fileName = Dir(dataFolder & "\" & tmpSheet.Range("A" & i).Value & "\*.csv") 'フォルダ内の最初のcsvファイル名を取得
  Do While fileName <> "" 'csvファイルがある間
   tmpSheet.Range("B" & R) = Left(fileName, InStrRev(fileName, ".") - 1) '作業シートのB列にcsvファイル名の名前のみ取得
   tmpSheet.Range("C" & R) = tmpSheet.Range("A" & i).Value '作業シートのC列にフォルダ名(日付)取得
   R = R + 1 '出力行+1
   fileName = Dir '次のcsvファイルを取得
  Loop
 Next
 'ファイル名、フォルダ名で並べ替え
 tmpSheet.Columns("B:C").Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=tmpSheet.Range("C1"), Order2:=xlAscending, Header:=xlNo
 'bookへcsvファイルを集計
 lastRow = tmpSheet.Range("B" & Rows.Count).End(xlUp).Row '作業シートのB列の最終行取得
 isOpen = False '集計ブックが開いているかどうかのフラグの初期値(閉じている)
 For R = 1 To lastRow 'B列の行数回
  fileName = dataFolder & "\" & tmpSheet.Range("C" & R).Value & "\" & tmpSheet.Range("B" & R).Value & ".csv" 'csvファイルのファイル名取得
  Set csv = Workbooks.Open(fileName) 'csvファイルを取得
  If Not isOpen Then '集計ブックが開いていなければ
   csv.Sheets(1).Copy 'csvファイルを新しいブックへコピー
   Set book = ActiveWorkbook '新しいブックactiveになっているので、book変数に取得
   isOpen = True '集計ブックフラグをありにする
  Else 'すでに集計ブックが開いていたら
   csv.Sheets(1).Copy After:=book.Sheets(book.Sheets.Count) '集計ブックの最後のシートの後ろにコピー
  End If
  book.Sheets(book.Sheets.Count).Name = tmpSheet.Range("C" & R).Value 'コピーしたシートの名前を日付にする
  csv.Close False 'csvファイルを閉じる
  If tmpSheet.Range("B" & R).Value <> tmpSheet.Range("B" & R + 1).Value Then '次のB列の値が違っていたら
   Application.DisplayAlerts = False
   
   Sheets.Add After:=Sheets(Sheets.Count)
   ActiveSheet.Name = "total"
   
   Range("A1").Select
   
   Set wsT = ActiveWorkbook.Worksheets("total")
   For Each ws In ActiveWorkbook.Worksheets
    If Not ws Is wsT Then
     N = N + 1
     ReDim Preserve Ranges(1 To N)
     With ws
      Ranges(N) = .Range("B1", .Cells(.Rows.Count, 3).End(xlUp)) _
       .Address(, , xlR1C1, True)
     End With
    End If
   Next
   With wsT
    .UsedRange.ClearContents
    .Range("A1").Consolidate Sources:=Ranges, Function:=xlSum, _
     TopRow:=False, LeftColumn:=True
   End With
   Columns("A:B").Select
   ActiveWorkbook.Worksheets("total").Sort.SortFields.Clear
   ActiveWorkbook.Worksheets("total").Sort.SortFields.Add Key:=Range("A1"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   With ActiveWorkbook.Worksheets("total").Sort
    .SetRange Range("A1:B10000")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
   End With
   Range("A1").Select
   Columns("A:A").Select
   Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   Columns("B:B").Select
   Selection.Copy
   Columns("A:A").Select
   ActiveSheet.Paste
   Range("A1").Select
   book.SaveAs dataFolder & "\" & tmpSheet.Range("B" & R).Value & ".csv", _
    FileFormat:=xlCSV, CreateBackup:=False '集計ブックを作業シートのB列の値(シート名)で保存
   book.Close False '集計ブックを閉じる
   isOpen = False '集計ブックが開いているかフラグを閉じているにする
  End If
 Next
 
 Application.Calculation = xlAutomatic '★
 Application.ScreenUpdating = True
End Sub
0 hits

【63908】マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 6:33 質問
【63910】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 10:40 発言
【63914】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 14:09 発言
【63916】Re:マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 15:13 発言
【63917】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 15:19 発言
【63918】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 15:31 回答
【63919】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 15:36 回答
【63921】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 17:12 回答
【63927】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 18:03 回答
【63928】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:10 発言
【63932】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 19:07 発言
【63933】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 19:40 発言
【63935】Re:マクロを早く快適に動かしたいです Hirofumi 09/12/31(木) 20:33 発言
【63936】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 21:01 発言
【63939】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 18:32 質問
【63940】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/1(金) 18:39 発言
【63942】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 19:16 お礼
【63948】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 22:23 発言
【63949】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 23:21 発言
【63950】Re:マクロを早く快適に動かしたいです kanabun 10/1/2(土) 23:29 発言
【63920】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 17:08 発言
【63924】Re:マクロを早く快適に動かしたいです つよぽん 09/12/31(木) 17:48 発言
【63925】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 17:53 発言
【63929】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:41 発言
【63931】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 18:50 発言
【63937】Re:マクロを早く快適に動かしたいです かみちゃん 09/12/31(木) 21:04 発言
【63934】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 20:14 発言
【63938】Re:マクロを早く快適に動かしたいです kanabun 09/12/31(木) 22:54 発言
【63941】Re:マクロを早く快適に動かしたいです つよぽん 10/1/1(金) 18:57 発言
【63943】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/1(金) 19:41 発言
【63930】Re:マクロを早く快適に動かしたいです よろずや 09/12/31(木) 18:44 発言
【63944】Re:マクロを早く快適に動かしたいです Yuki 10/1/2(土) 10:46 発言
【63945】Re:マクロを早く快適に動かしたいです かみちゃん 10/1/2(土) 11:11 発言

18271 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free