Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2013)
高速化について
投稿日時: 19/04/19 09:28:45
投稿者: current

プログラムの再生速度を調査したところ、8割が下記コードの Do While filename <> Empty で時間がかかっていました。ファイルの数にも依りますが、30秒ほどかかります。もう少し速くしたいのですが、改善する方法ありますでしょうか?ご存知でしたら教えてください。よろしくお願いいたしますm__m
 
 

fileopen1 = Timer
            Do While filename <> Empty
            fileopen2 = Timer
                If filename <> ThisWorkbook.Name Then  '統合先ブックと異なるブック名であれば
                    Set currentbook = Workbooks.Open(ThisWorkbook.Path & "\" & filename, ReadOnly:=True)
                    currentbook.Worksheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    bookname = currentbook.Name
                    currentbook.Close
                    ActiveWindow.ScrollRow = 1
                    ActiveWindow.ScrollColumn = 1
                    fileopen3 = Timer
                    Call data_calcu
                    filecalcu = Timer
                    Call chart_data_collecting
                    datacollecting = Timer
                    Call chart_making
                    chartmaking = Timer
                End If
                filename = Dir 'フォルダ内の次のブック名を取得
            Loop

回答
投稿日時: 19/04/19 09:51:25
投稿者: sk

引用:
Call data_calcu

引用:
Call chart_data_collecting

引用:
Call chart_making

これらのプロシージャの内容が明示されない限り、
誰にも答えようがないと思います。

回答
投稿日時: 19/04/19 10:15:47
投稿者: hatena
投稿者のウェブサイトに移動

引用:
プログラムの再生速度を調査したところ、8割が下記コードの Do While filename <> Empty で時間がかかっていました。ファイルの数にも依りますが、30秒ほどかかります。

 
Do While filename <> Empty の1行のコードに時間がかかっていると思っているなら、それはありえません。
 
Do While
・・・
Loop
内の処理全体で時間がかかっていると考えているなら、それはあってます。
 
ところで、コード中に変数に Timer を代入しているコードが散見しますが、
これで処理時間を計測しようとしているのだと思いますが、
その結果を取得するコードが提示のコードにはありません。
 
そのコードも提示してもらえますか。
処理時間の計測がまちがっていたら正しい判断ができませんので。
 
Do While
・・・
Loop
内で複数の処理をしていますので、そのどの処理に時間がかかっているか、処理ごとに計測する必要がありますが、そのようにしてますか。
 
あと「ファイルの数にも依りますが」とのことですが、どのくらいのファイル数で30秒なんですか。
 

投稿日時: 19/04/19 10:59:48
投稿者: current

失礼いたしました。結果を取得しているコードを添付いたします。
ファイル数は今は10個で試しています。これからどんどん増えていくので改善を希望しております。
 

processtime = endtime - starttime
    processtime1 = fileopen1 - starttime
    processtime2 = fileopen2 - fileopen1
    processtime3 = fileopen3 - fileopen2
    processtime4 = filecalcu - fileopen3
    processtime5 = datacollecting - filecalcu
    processtime6 = chartmaking - datacollecting
    
    Range("d10000").Select
    ActiveCell = "日付"
    Selection.Offset(0, 1) = "時間"
    Selection.Offset(0, 2) = "合計時間"
    Selection.Offset(0, 3) = "fileopen1"
    Selection.Offset(0, 4) = "fileopen2"
    Selection.Offset(0, 5) = "fileopen3"
    Selection.Offset(0, 6) = "filecalcu"
    Selection.Offset(0, 7) = "datacollecting"
    Selection.Offset(0, 8) = "chartmaking"
    Selection.Offset(0, 9) = "worksheets"
        If Range("d10001") <> "" Then
            Selection.End(xlDown).Select
        End If
    Selection.Offset(1, 0).Select
    ActiveCell = "=now()"
    ActiveCell.NumberFormatLocal = "yyyy/m/dd"
    Selection.Offset(0, 1) = "=now()"
    Selection.Offset(0, 1).NumberFormatLocal = "[$-F400]h:mm:ss AM/PM"
    Selection.Offset(0, 2) = processtime
    Selection.Offset(0, 3) = processtime1
    Selection.Offset(0, 4) = processtime2
    Selection.Offset(0, 5) = processtime3
    Selection.Offset(0, 6) = processtime4
    Selection.Offset(0, 7) = processtime5
    Selection.Offset(0, 8) = processtime6
    Range(Selection, Selection.Offset(0, 1)).Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues

回答
投稿日時: 19/04/19 12:46:01
投稿者: よろずや

見た感じ、Select を多用していますが、これが遅い原因かと思います。
 
Select を使わずに書く書き方は諸兄が指導してくれると思います。

投稿日時: 19/04/19 13:14:09
投稿者: current

ご回答ありがとうございます。selectが多いとのことですが、offsetなどを使用して無駄なアクティブ回数を減らすことを指しておりますでしょうか?それ以外の意味がありましたらご教授くださいm__m

回答
投稿日時: 19/04/19 15:03:45
投稿者: Suzu

断片的にコードを提示頂いても、
・どんな呼び出され方をしているのか
・ループに中からの呼び出しなのか
判断しかねます。
 
少なくとも

引用:
Range("d10000").Select
    ActiveCell = "日付"
    Selection.Offset(0, 1) = "時間"
    Selection.Offset(0, 2) = "合計時間"
    Selection.Offset(0, 3) = "fileopen1"
    Selection.Offset(0, 4) = "fileopen2"
    Selection.Offset(0, 5) = "fileopen3"
    Selection.Offset(0, 6) = "filecalcu"
    Selection.Offset(0, 7) = "datacollecting"
    Selection.Offset(0, 8) = "chartmaking"
    Selection.Offset(0, 9) = "worksheets"

 
例えば
Range("d10000").Resize(1, 9).Value = _
  Split("日付;時間;合計時間;fileopen1;fileopen2;fileopen3;filecalcu;datacollecting;chartmaking;worksheets", ";")
 
とか。
 
 
 
引用:
If Range("d10001") <> "" Then
            Selection.End(xlDown).Select
        End If

この条件分岐があるという事はサブルーチンの処理?
だとすれば、前述のd10000 の行に対する処理はラベル処理なのですよね?
それをサブルーチン側で何とも呼び出す必要って、、あるのですか?
 
 
引用:
ActiveCell = "=now()"
    ActiveCell.NumberFormatLocal = "yyyy/m/dd"
    Selection.Offset(0, 1) = "=now()"
    Selection.Offset(0, 1).NumberFormatLocal = "[$-F400]h:mm:ss AM/PM"
      :
 

 
With ActiveCell
  .Value = Format(Now(),"yyyy/m/dd")
  .Offset(0,1).Value = Format(Now(),"yyyy/m/dd")
    :
  .Offset(0, 2) = processtime
  .Offset(0, 3) = processtime1
End With
 
 
 
必要ならループの外で
    ActiveCell.NumberFormatLocal = "yyyy/m/dd"
    Range(Selection, Selection.Offset(0, 1)).Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues
の処理を、範囲すべてに対し行う。
 
わざわざ、1セルごとまたは、1行毎に行う必要はない。

回答
投稿日時: 19/04/19 16:58:38
投稿者: hatena
投稿者のウェブサイトに移動

提示していただいたのは、処理時間計測の結果を出力するコードですよね。
分かりずらいですし、セルに出力していてはその分重くなります。
 
とりあえず、Do Loop内のどの処理に時間がかかっているかもっとシンプルに計測しましょう。
また、出力はセルではなくイミディエイトウィンドウにしましょう。
 
現状のコードに下記のように処理時間計測用のコードを埋め込んでください。
 

    Dim FileName As String
    Dim sTime As Single
    Dim WorksheetsCopyTime As Singel
    Dim data_calcuTime As Singel
    Dim chart_data_collectingTime As Singel
    Dim chart_makingTime As Singel

     '中略(不明なので)

    Do While FileName <> ""
         If FileName <> ThisWorkbook.Name Then  '統合先ブックと異なるブック名であれば
            
            sTime = Timer '※計測開始
            Set currentbook = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, ReadOnly:=True)
            currentbook.Worksheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            bookname = currentbook.Name
            currentbook.Close
            ActiveWindow.ScrollRow = 1
            ActiveWindow.ScrollColumn = 1
            WorksheetsCopyTime = WorksheetsCopyTime + Timer - sTime '※計測結果を加算
            
            sTime = Timer '※計測開始
            Call data_calcu
            data_calcuTime = data_calcuTime + Timer - sTime '※計測結果を加算
            
            sTime = Timer '※計測開始
            Call chart_data_collecting
            chart_data_collectingTime = chart_data_collectingTime + Timer - sTime '※計測結果を加算
            
            sTime = Timer '※計測開始
            Call chart_making
            chart_makingTime = chart_makingTime + Timer - sTime '※計測結果を加算
        End If
        FileName = Dir 'フォルダ内の次のブック名を取得
    Loop
    
    Debug.Print "WorksheetsCopyTime   : " & WorksheetsCopyTime
    Debug.Print "data_calcu           : " & data_calcuTime
    Debug.Print "chart_data_collecting: " & chart_data_collectingTime
    Debug.Print "chart_making         : " & chart_makingTime

 
これを実行すると、各処理ごとの処理時間がイミディエイトウィンドウに出力されますので、
その結果をコピーして貼り付けてもらえますか。
 
そこで、一番時間がかかっている処理から対策するのが効率的です。。

回答
投稿日時: 19/04/21 13:54:24
投稿者: WinArrow
投稿者のウェブサイトに移動

>Do While filename <> Empty
 
変数:filenameをVariant型で定義すると、Emptyにはなりますが、
Dir関数で、ファイル名を取得しています。
お望みのファイルが存在しない場合には、空白文字列が格納されるので
何時まで経っても「Empty]にはならなと思いますが・・・

回答
投稿日時: 19/04/21 17:09:50
投稿者: よろずや

Empty は特殊な値で、文脈によって値が変わります。
文字列と比較すると空文字列に、
数値と比較するとゼロになります。
("" = Empty) → True
(0 = Empty) → True

回答
投稿日時: 19/04/21 20:31:07
投稿者: WinArrow
投稿者のウェブサイトに移動

よろずや さんの引用:
Empty は特殊な値で、文脈によって値が変わります。
文字列と比較すると空文字列に、
数値と比較するとゼロになります。
("" = Empty) → True
(0 = Empty) → True

なるほど
  
しかし、↓のようなこと(極端かもしれませんが)を考えたら、
 リスクを感じますが・・・
  
Dim FN
   
     FN = "ABC"
     If FN = "ABC" Then '条件合致
 
 
 

回答
投稿日時: 19/04/22 09:59:48
投稿者: Suzu

WinArrow さんの引用:

しかし、↓のようなこと(極端かもしれませんが)を考えたら、
 リスクを感じますが・・・
  
Dim FN
   
     FN = "ABC"
     If FN = "ABC" Then '条件合致

 
すみません。教えてください。
何がリスクなのかわからないのです。

回答
投稿日時: 19/04/22 11:52:04
投稿者: WinArrow
投稿者のウェブサイトに移動

>何がリスクなのかわからないのです。
 
そうですね。例が悪かったですね
 
昔、IsEMptyとEmptyを混乱して使って、トラぶったことを思い出し、
リスクがあると記述してしまいました。
 
本当にEmptyなのか、見做しのEnptyなのかを判断して処理する場合は、
=Emptyは使うべきではないということだと思います。
 
Sub test()
Dim data
 
    If data = Empty Then MsgBox "本当のEmpty"
    data = 0
    If data = Empty Then MsgBox "0をEmptyと見做したよ"
    data = ""
    If data = Empty Then MsgBox "空白文字列をEmptyと見做したよ"
End Sub
 

回答
投稿日時: 19/04/22 17:43:20
投稿者: Suzu

引用:
昔、IsEMptyとEmptyを混乱して使って、トラぶったことを思い出し、
リスクがあると記述してしまいました。

 
例で判りました。ありがとうございました。

投稿日時: 19/04/25 18:28:39
投稿者: current

ありがとうございます。上手くいきました。
たびたびお手数をおかけいたし申し訳ありませんが、繰り返し起動したときに、繰り返し表示されていきますので、わかるように日付を最後に記載させたいのですが、この場合、worksheetfunction.now()は使えないのでしょうか?(使用者が私以外にもいますのでコピーせずに残していく方法を取ろうと思っています)
 

Debug.Print "data_calcu:"; data_calcuTime & WorksheetFunction.Now()

回答
投稿日時: 19/04/25 19:14:17
投稿者: WinArrow
投稿者のウェブサイトに移動

>この場合、worksheetfunction.now()は使えないのでしょうか?
 
使えません。
 
単純に
Now
だけ記述すればよいです。
 
ときに・・・・・
>使用者が私以外にもいますのでコピーせずに残していく方法
 
この意味がよくわかりません・・・というか、Debug.Printでよいのですか?

投稿日時: 19/04/25 20:06:36
投稿者: current

ご回答ありがとうございます。
動作時間優先に考えていましたので、イミディエイトに入れてみようと思っています。本当は結果を観察するのにメモが取れて履歴が残るシートに転機を考えていましたが、遅くなるなら本末転倒ですので(--;)
HATENAさんが記載してくれたコードで時間がイミディエイトに反映されるようになりましたが、合計時間を追加して見比べると、足しても合計と同じにならないことが判明しました。今パソコンがネットに繋がっていないのでコードを記載出来ませんので、必要でしたら明日記載致しますが、結果と致しましては、合計の方が少なくなっており、ストップウォッチで測定すると合計と同じになるので、合計の間違いはないと思いますので、どこに間違いがあるようです。。。

回答
投稿日時: 19/04/25 21:14:23
投稿者: simple

横から失礼します。
 
>合計時間を追加して見比べると、足しても合計と同じにならないことが判明しました。
あなたがどのように「合計時間」を測定したのか書いていただかないと
差異は他人にはわかりません。
どのくらいの差異があるのですか?

回答
投稿日時: 19/04/26 10:14:31
投稿者: hatena
投稿者のウェブサイトに移動

current さんの引用:
動作時間優先に考えていましたので、イミディエイトに入れてみようと思っています。本当は結果を観察するのにメモが取れて履歴が残るシートに転機を考えていましたが、遅くなるなら本末転倒ですので(--;)
HATENAさんが記載してくれたコードで時間がイミディエイトに反映されるようになりましたが、合計時間を追加して見比べると、足しても合計と同じにならないことが判明しました。今パソコンがネットに繋がっていないのでコードを記載出来ませんので、必要でしたら明日記載致しますが、結果と致しましては、合計の方が少なくなっており、ストップウォッチで測定すると合計と同じになるので、合計の間違いはないと思いますので、どこに間違いがあるようです。。。

 
私の提示したコードは、ループ内の各処理毎の処理時間の合計です。
ループのWhile判定、ループ内でのIf文やDirの処理時間は含まれてませんので、ループ全体の処理時間と、各処理時間の合計が一致するとは限りません。(ループ全体の時間 > 各処理時間の合計)
 
While判定、ループ内でのIf文やDirはこれ以上改善する余地はないので無視していいと思います。
 
各処理で一番時間がかかっているものから、高速化の対策をするのが効率的ですので、一度実行させて、どれに時間がかかっているか分かればいいので、シートに保存させておくほどのものでもないと思います。
 
保存するにしても、ループを抜けてから、合計時間を転記するだけですので、計測自体に影響はないです。
 
で、実行させた結果、各処理にかかった時間はどうなりました。
とりあえず、一番時間のかかる処理のコードを提示したら、高速化のアドバイスができるかと思います。
 
高速化の対策がすんだら、処理時間計測処理は不要なので削除していいです。

回答
投稿日時: 19/04/26 11:05:09
投稿者: WinArrow
投稿者のウェブサイトに移動

処理の内容を隠したまま、どこの問題があるのでしょう?
なんて、虫のいい質問はいかがなものでしょう?
 
やみくもにコードを書いているような気がします。
まず、コードを書く前に、要件の整理をしましょう。
 
ブックを開く〜閉じるまでの時間を計測するという前提で
↓のようなコードを紹介します。
 
Private Type FileOpen
    FNAME As String
    FSTART As Single
    FCLOSE As Single
End Type
 
Sub test()
Dim FOPEN() As FileOpen
Dim Fx As Long
Dim F, SrcBook As Workbook, DstBook As Workbook
 
    Set DstBook = ThisWorkbook
    Fx = 0
    ReDim FOPEN(Fx)
    With CreateObject("SCripting.Filesystemobject")
        For Each F In .getFolder("D:\TEST").Files
            If F.Name Like "*.xls?" Then
                Fx = Fx + 1
                ReDim Preserve FOPEN(Fx)
                FOPEN(Fx).FNAME = F.Name
                Set SrcBook = Workbooks.Open(Filename:=F.Path)
                FOPEN(Fx).FSTART = Timer
                '処理
                SrcBook.Close False
                FOPEN(Fx).FCLOSE = Timer
            End If
        Next
    End With
    For Fx = LBound(FOPEN) To UBound(FOPEN)
        If Fx > 0 Then
            Debug.Print "FILENAME:" & FOPEN(Fx).FNAME & vbTab;
            Debug.Print " FILEOPEN:" & FOPEN(Fx).FSTART & vbTab;
            Debug.Print " FILECLOSE:" & FOPEN(Fx).FCLOSE
        End If
    Next
End Sub
 
これで、ブックごとのOPENTIME、CLOSETIMEが取得できます。
 
 
 
 

投稿日時: 19/04/26 12:04:53
投稿者: current

皆様、ご回答ありがとうございます。
現在の進捗になりますが、イミディエイトウインドウに表示された時間は下記になります。やはりそれぞれを集計するとtotaltimeより時間が長くなるのが少し気になりますが、これによりループだけに時間がかかっているわけではないことがわかりました。ありがとうございましたm__m下記の主に時間がかかっている上位からコードを2つ記載いたします。乱筆になりますが、改善点のご教授よろしくお願いいたします。
 
WorksheetCopyTime:11.59766 (2019/04/26 11:49:07 )
data_calcu: 13.32031 (2019/04/26 11:49:07 )
chart_data_collecting:13.24219 (2019/04/26 11:49:07 )
chart_making:3.4375 (2019/04/26 11:49:07 )
sheet_name_get:0 (2019/04/26 11:49:07 )
totalTime: 30.21875 (2019/04/26 11:49:07 )
 

Sub sheets_combine_to_summarizing()

Dim filename As String '作業するフォルダのパス'作業するファイル名のリスト
Dim sTime, WorksheetsCopyTime, data_calcuTime, chart_data_collectingTime, chart_makingTime, sheet_name_getTime As Single

    starttime = Timer
    Application.ScreenUpdating = False  '画面更新を停止
    Application.DisplayAlerts = True
    Application.calculation = xlManual  '計算方法 手動
    
    Range("a16").Select
    Range(Selection, Selection.Offset(0, 4)).Select
    Range(Selection, Selection.End(xlDown)).Select
    scdrange = Selection.Address
        If WorksheetFunction.CountBlank(Range(scdrange)) <> 0 Then
            MsgBox Application.WorksheetFunction.CountBlank(Range(scdrange)) & "ヶ所条件を入力してください"
            Selection.SpecialCells(xlCellTypeBlanks).Select
            Exit Sub
        End If
    filename = Dir(ThisWorkbook.Path & "\*.*")
        If LCase(ThisWorkbook.Path) Like "*.csv" Or _
           LCase(ThisWorkbook.Path) Like "*xls*" Then
        End If
            Do While filename <> Empty
                If filename <> ThisWorkbook.Name Then  '統合先ブックと異なるブック名であれば
                    sTime = Timer '計測開始
                    Set currentbook = Workbooks.Open(ThisWorkbook.Path & "\" & filename, ReadOnly:=True)
                    currentbook.Worksheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    bookname = currentbook.Name
                    currentbook.Close
                    ActiveWindow.ScrollRow = 1
                    ActiveWindow.ScrollColumn = 1
                    WorksheetsCopyTime = WorksheetsCopyTime + Timer - sTime '計測結果を加算
                    sTimer = Timer '計測開始
                    Call data_calcu
                    data_calcuTime = data_calcuTime + Timer - sTime '計測結果を加算
                    sTime = Timer '計測開始
                    Call chart_data_collecting
                    chart_data_collectingTime = chart_data_collectingTime + Timer - sTime '計測結果を加算
                    sTime = Timer '計測開始
                    Call chart_making
                    chart_makingTime = chart_makingTime + Timer - sTime '計測結果を加算
                End If
                filename = Dir 'フォルダ内の次のブック名を取得
            Loop
    sTime = Timer
    Call sheet_name_get
    sheet_name_getTime = sheet_name_getTime + Timer - sTime '計測結果を加算
    endtime = endtime + Timer - starttime
    
    Debug.Print "WorksheetCopyTime:" & WorksheetsCopyTime; " ("; Now(); ")"
    Debug.Print "data_calcu:"; data_calcuTime; " ("; Now(); ")"
    Debug.Print "chart_data_collecting:" & chart_data_collectingTime; " ("; Now(); ")"
    Debug.Print "chart_making:" & chart_makingTime; " ("; Now(); ")"
    Debug.Print "sheet_name_get:" & sheet_name_getTime; " ("; Now(); ")"
    Debug.Print "totalTime:"; endtime; " ("; Now(); ")"

    Application.ScreenUpdating = True '画面更新を再開
    Application.calculation = xlAutomatic '計算方法 自動
    Application.DisplayAlerts = True
    ActiveWindow.Visible = True
End Sub

Sub chart_data_collecting()

Dim i, j, k, l, m, n, o, q, r, v, w, x, y, z, aa, bb As Long
Dim dd As Double

    l = 2
    Range("c1").Select
        For i = 1 To 8
            Selection.End(xlDown).Select
        Next i
    ActiveCell.Offset(2, 0).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.Offset(0, -1)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Calculate
    Selection.Copy
    Range("R2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
        For j = 1 To Val(Range("C8").Value) - 1
            Range("A28").Select
                For k = 1 To l
                    Selection.End(xlDown).Select
                Next k
            l = l + 2
            ActiveCell.Offset(3, 3).Select
            Range(Selection, Selection.Offset(0, 1)).Select
            Range(Selection, Selection.End(xlDown)).Select
            Calculate
            Selection.Copy
            Range("R2").Select
            Selection.End(xlToRight).Select
            ActiveCell.Offset(0, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Next j
    m = 18
    n = 1
        For o = 1 To Range("C8").Value * 2
            If Cells(2, m).Value <> "" Then
                Cells(1, m) = "N" & n
                m = m + 1
                n = n + 1
            End If
        Next o
    z = 1
    v = 18
    q = 19
        For x = 1 To Range("C8").Value
            Range("R1").Select
            Selection.End(xlToRight).Select
            ActiveCell.Offset(0, 1).Select
            ActiveCell = "N" & z
            z = z + 1
            ActiveCell.Offset(0, 1) = "N" & z
            z = z + 1
            ActiveCell.Offset(1, 0).Select
            r = 2
            w = 2
            aa = Range("C8").Value * 2
            ActiveCell.FormulaR1C1 = "=IF(RC[" & -aa + 1 & "]>" & Worksheets("main").Range("G14").Value & ",RC[" & -aa & "],"""")"
            ActiveCell.Offset(0, 1).Select
            ActiveCell.FormulaR1C1 = "=IF(RC[" & -aa & "]> " & Worksheets("main").Range("G14").Value & ",RC[" & -aa & "],"""")"
            Range(Selection, Selection.Offset(0, -1)).Copy
            ActiveCell.Offset(0, -aa - 1).Select
            Selection.End(xlDown).Select
            ActiveCell.Offset(0, aa).Select
            Range(Selection, Selection.End(xlUp)).Select
            ActiveSheet.Paste
        Next x
    Calculate
    Columns("R:R").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
        For y = 1 To aa
            Range("R1").Select
            Columns(18 + aa).Select
            Selection.TextToColumns Destination:=Cells(1, 18 + aa), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
              :=Array(1, 1), TrailingMinusNumbers:=True
            aa = aa + 1
        Next y
    Columns("R:R").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp
    z = 1
        For bb = 1 To Range("C8").Value
            Range("R1").Select
            Selection.End(xlToRight).Select
            ActiveCell.Offset(0, 1).Select
            ActiveCell = "N" & z
            z = z + 1
            ActiveCell.Offset(0, 1) = "N" & z
            z = z + 1
            ActiveCell.Offset(1, 0).Select
            r = 2
            w = 2
            aa = Range("C8").Value * 2
            ActiveCell.FormulaR1C1 = "= rc[" & -aa & "]-r2c[" & -aa & "]"
            ActiveCell.Offset(0, 1).Select
            ActiveCell.FormulaR1C1 = "= rc[" & -aa & "]"
            Range(Selection, Selection.Offset(0, -1)).Copy
            ActiveCell.Offset(0, -aa - 1).Select
            Selection.End(xlDown).Select
            ActiveCell.Offset(0, aa).Select
            Range(Selection, Selection.End(xlUp)).Select
            ActiveSheet.Paste
        Next bb
    ff = Range("C8").Value
    hh = 16 + ff - 1
    ee = 18 + Range("C8") * 2 * 2
    Calculate
        For gg = 1 To ff
            dd = Application.Round(Cells(hh, 15), 6)
            cc = Columns(ee + 1).Find(What:=dd, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns).Row
            Cells(hh, 16) = Cells(cc, ee).Value
            ee = ee + 2
            hh = hh + 1
        Next gg
End Sub

回答
投稿日時: 19/04/26 14:45:33
投稿者: WinArrow
投稿者のウェブサイトに移動

TIMER 関数は、本日の00:00:00からの経過時間を取得する関数なので、
その計測したい処理の開始から終了の差を加算しないと意味がないと思う。
そのような処理になっていますか?
 
計測対象の処理の名称が理解できません。
NoW関数で取得したデータはどんな意味があるのかわかりませんが、
全て同じ値を表示してるが、どんな意図があるんですか?
 

回答
投稿日時: 19/04/26 14:54:16
投稿者: WinArrow
投稿者のウェブサイトに移動

 
他の回答者からも指摘があったと思いますが、
随所に「SELECT」「OFFSET」が出てくる
 
随所というより、「SELECT」「OFFSET」のオンパレード・・・・
「SELECT」「OFFSET」を全部、外す修正をしてみたらいかがですか?
  
処理時間の話に戻りますが、
  
何と何を加算したら合計時間になると考えているのか?
その説明ができますか?
 
 

回答
投稿日時: 19/04/26 16:28:40
投稿者: WinArrow
投稿者のウェブサイトに移動

[SELECT][OFFSET]を止めるに関して
一部分ではあるが、
 次のように改善することができる
  
ブロック1
    Range("a16").Select
     Range(Selection, Selection.Offset(0, 4)).Select
     Range(Selection, Selection.End(xlDown)).Select
     scdrange = Selection.Address
   
  [SELECT]x3回、[SELECTION]x5回、[OFFSET]x1回
    ↓
       
  セル範囲がセルA16と隣接しているならば、1行で済むし[SELECT]も[OFFSET]もない
    With ActiveSheet
         scdrange = .Range("A16").CurrentRegion.Address
     End With
   
   
   
次のコードは、まったく意味が理解できません。
  
         If LCase(ThisWorkbook.Path) Like "*.csv" Or _
            LCase(ThisWorkbook.Path) Like "*xls*" Then
         End If
 ※処理対象のファイルを「csv」と「xls」に絞り込んでいると思いますが、
Do〜Loopの外に記述しているから、絞り込んでいるおとにはなりません。
処理時間に影響しないとおもうが、意図がわかりません。
  
   
このようにコードを見直すと、無駄な動きが多く見受けられます。
 回答者は、貴方のプログラムのデバッガーではないです。
  
処理時間を計測して、問題を解決するというならば、
ファイルごとに計測したい時間を記録しないと、どこに問題があるのか?
 門外漢に問うても答えはでないでしょう。
  
  

回答
投稿日時: 19/04/26 16:46:46
投稿者: hatena
投稿者のウェブサイトに移動

引用:

                    WorksheetsCopyTime = WorksheetsCopyTime + Timer - sTime '計測結果を加算
                    sTimer = Timer '計測開始
                    Call data_calcu

 
sTimerという変数は宣言してませんね。sTimeのタイプミスだと思います。
そのために処理時間が正確に計測できてないのです。
 
とりあえず、これを修正して、処理時間を計測して結果を教えてください。
 

回答
投稿日時: 19/04/26 16:50:04
投稿者: hatena
投稿者のウェブサイトに移動

WinArrow さんの引用:
TIMER 関数は、本日の00:00:00からの経過時間を取得する関数なので、
その計測したい処理の開始から終了の差を加算しないと意味がないと思う。
そのような処理になっていますか?

変数のタイプミスを修正すれば、なっていると思います。

回答
投稿日時: 19/04/26 17:22:13
投稿者: hatena
投稿者のウェブサイトに移動

引用:
WorksheetCopyTime:11.59766 (2019/04/26 11:49:07 )
data_calcu: 13.32031 (2019/04/26 11:49:07 )
chart_data_collecting:13.24219 (2019/04/26 11:49:07 )
chart_making:3.4375 (2019/04/26 11:49:07 )
sheet_name_get:0 (2019/04/26 11:49:07 )
totalTime: 30.21875 (2019/04/26 11:49:07 )

 
WorksheetCopyTime は変数のタイプミスのため、正確でないので無視するとして、
data_calcu で13秒、
chart_data_collecting も13秒、
トータルで 30秒ですので、上記の2つのプロシージャから対策するのがいいことが分かります。
 
提示されている chart_data_collecting プロシージャを見てみると、
WinArrowさんも指摘されてるように、無意味な Select が多いのが第一の原因ですね。
 
とりあえず下記を参考に、Selectせずにコピーする方法に書き換えればかなり改善できると思います。
 
Office TANAKA - VBA高速化テクニック[Selectしない]
http://officetanaka.net/excel/vba/speed/s2.htm
 
 
他にも、いろいろ高速化のテクニックはありますが、まずは上記の対策をしてみてください。
 
 

回答
投稿日時: 19/04/26 17:48:17
投稿者: WinArrow
投稿者のウェブサイトに移動

hatenaさん、お疲れ様です。
[SELECT][OFFSET]のオンパレードで
コードを追っかける気にもなれず
なかば、もうやめようとしていたおころです。
 
コードミスには気が付きませんでした。
 

hatena さんの引用:

WorksheetCopyTime は変数のタイプミスのため、正確でないので無視するとして、
data_calcu で13秒、
chart_data_collecting も13秒、
トータルで 30秒ですので、上記の2つのプロシージャから対策するのがいいことが分かります。

>WorksheetCopyTime は変数のタイプミスのため
と書かれていますが、
data_calcu
の計測開始のコードで使っている sTimer なので
data_calcu には、WorksheetCopyTimeが含まれていると思われます。
 
 
問題のコード
引用:

                    sTimer = Timer '計測開始
                    Call data_calcu
                    data_calcuTime = data_calcuTime + Timer - sTime '計測結果を加算

 
current さんへ
モジュールの先頭に↓を記述すると、変数入力ミスをチェックしてくれます。
 
Option Explicit
 
 
 

投稿日時: 19/04/26 17:52:17
投稿者: current

皆さんのおっしゃる通りタイプミスが原因でした。ありがとうございました。まずchart_data_collectingを見直そうと思います。
 
WorksheetCopyTime:11.71094 (2019/04/26 17:38:52 )
data_calcu: 1.894531 (2019/04/26 17:38:52 )
chart_data_collecting:11.44141 (2019/04/26 17:38:52 )
chart_making:3.5 (2019/04/26 17:38:52 )
sheet_name_get:0 (2019/04/26 17:38:52 )
totalTime: 28.54688 (2019/04/26 17:38:52 )
 
理解できていない部分がありました。修正しましたのでご確認よろしくお願いいたします。
now関数は連続して実施したときに区別するために記載しています。
 
[code]Sub sheets_combine_to_summarizing()
 
Dim filename As String '作業するフォルダのパス'作業するファイル名のリスト
Dim sTime, WorksheetsCopyTime, data_calcuTime, chart_data_collectingTime, chart_makingTime, sheet_name_getTime As Single
 
    starttime = Timer
    Application.ScreenUpdating = False '画面更新を停止
    Application.DisplayAlerts = True
    Application.calculation = xlManual '計算方法 手動
     
    With ActiveSheet
        scdrange = .Range("A16").CurrentRegion.Address
    End With
        If WorksheetFunction.CountBlank(Range(scdrange)) <> 0 Then
            MsgBox Application.WorksheetFunction.CountBlank(Range(scdrange)) & "ヶ所条件を入力してください"
            Selection.SpecialCells(xlCellTypeBlanks).Select
            Exit Sub
        End If
        filename = Dir(ThisWorkbook.Path & "\*.*")
            Do While filename <> Empty
                    If LCase(ThisWorkbook.Path) Like "*.csv" Or _
                       LCase(ThisWorkbook.Path) Like "*xls*" Then
                    End If
                    If filename <> ThisWorkbook.Name Then '統合先ブックと異なるブック名であれば
                        sTime = Timer '計測開始
                        Set currentbook = Workbooks.Open(ThisWorkbook.Path & "\" & filename, ReadOnly:=True)
                        currentbook.Worksheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                        bookname = currentbook.Name
                        currentbook.Close
                        ActiveWindow.ScrollRow = 1
                        ActiveWindow.ScrollColumn = 1
                        WorksheetsCopyTime = WorksheetsCopyTime + Timer - sTime '計測結果を加算
                        sTime = Timer '計測開始
                        Call data_calcu
                        data_calcuTime = data_calcuTime + Timer - sTime '計測結果を加算
                        sTime = Timer '計測開始
                        Call chart_data_collecting
                        chart_data_collectingTime = chart_data_collectingTime + Timer - sTime '計測結果を加算
                        sTime = Timer '計測開始
                        Call chart_making
                        chart_makingTime = chart_makingTime + Timer - sTime '計測結果を加算
                    End If
                filename = Dir 'フォルダ内の次のブック名を取得
            Loop
    sTime = Timer
    Call sheet_name_get
    sheet_name_getTime = sheet_name_getTime + Timer - sTime '計測結果を加算
    endtime = endtime + Timer - starttime
     
    Debug.Print "WorksheetCopyTime:" & WorksheetsCopyTime; " ("; Now(); ")"
    Debug.Print "data_calcu:"; data_calcuTime; " ("; Now(); ")"
    Debug.Print "chart_data_collecting:" & chart_data_collectingTime; " ("; Now(); ")"
    Debug.Print "chart_making:" & chart_makingTime; " ("; Now(); ")"
    Debug.Print "sheet_name_get:" & sheet_name_getTime; " ("; Now(); ")"
    Debug.Print "totalTime:"; endtime; " ("; Now(); ")"
 
    Application.ScreenUpdating = True '画面更新を再開
    Application.calculation = xlAutomatic '計算方法 自動
    Application.DisplayAlerts = True
    ActiveWindow.Visible = True
End Sub [/quote]

引用:
[quote]

回答
投稿日時: 19/04/26 20:36:07
投稿者: hatena
投稿者のウェブサイトに移動

WinArrow さんの引用:
>WorksheetCopyTime は変数のタイプミスのため
と書かれていますが、
data_calcu
の計測開始のコードで使っている sTimer なので
data_calcu には、WorksheetCopyTimeが含まれていると思われます。

あら、そうですね。勘違いしてました。(;'∀')
 
current さんの引用:

WorksheetCopyTime:11.71094 (2019/04/26 17:38:52 )
data_calcu: 1.894531 (2019/04/26 17:38:52 )
chart_data_collecting:11.44141 (2019/04/26 17:38:52 )
chart_making:3.5 (2019/04/26 17:38:52 )
sheet_name_get:0 (2019/04/26 17:38:52 )
totalTime: 28.54688 (2019/04/26 17:38:52 )

 
各処理の計が
11.71094 + 1.894531 + 11.44141 + 3.5 + 0 = 28.546881
ですので、totalTime: 28.54688 とほぼ同じですので、正確でしょうね。
 
WorksheetCopyTime が11秒かかってますが、これは、ブックを開く→シートをコピー→ブックを閉じる
という処理ですが、高速化は難しいかな。
 
chart_data_collecting は Select をやめればかなり高速化できると思います。[/quote]

回答
投稿日時: 19/04/26 20:49:31
投稿者: simple

まず変数を適切に宣言することから始めてください。
http://officetanaka.net/excel/vba/beginner/06.htm
を参考にしてください。
 
(1)Option Explicit の重要性をきちんと理解することが大切です。
   これを使っていれば、今回のようなトラブルは回避できたはずです。
(2)Option Explicitを自動的に挿入してくれる方法が上の記事にあります。
   これを守ると幸せになれます。必ず実行してください。
(3)なお、変数の型の宣言は個々の変数毎にします。
   例:

Dim i, j, k As Long
としたときLongなのは kだけで、あとは Variant型です。
Dim i As Long, j As Long, k As Long
とする必要があります。
  
それとインデントを正確につけることですね。

回答
投稿日時: 19/04/26 22:22:36
投稿者: WinArrow
投稿者のウェブサイトに移動

最後に掲示していただいたコードの中にも
意味不明や意図不明や無駄なコードがたくさん見受けられます。
 
その中の一つ

引用:

                    If LCase(ThisWorkbook.Path) Like "*.csv" Or _
                        LCase(ThisWorkbook.Path) Like "*xls*" Then
                     End If

このコードは、Do〜Loopの中に入れたまではよかったですが、
多分、Dir関数で取得した対象ファイルの判断していると思います。
 
そうすると
(1)チェックしている対象が間違っています。
  対象が、「Thisworbook.Path」になっています。
  正解は、
  
If LCase(filename) Like "*.csv" Or _ 
    LCase(filename) Like "*xls*" Then 

でしょうね?
→ End If はLoopの前へ
 
 
以下、意味不明なコード
 
(1)「chart_data_collecting」プロシジャの中
引用:

    l = 2
    Range("c1").Select
        For i = 1 To 8
            Selection.End(xlDown).Select
        Next i

このコードは意味不明なコードです。
(表のレイアウトが説明されていないので、判断できない)
何をしようとしているか理解できません。
ループの中で、変数「i」が使われていない?
 
(2)セルの中身が変わっていないのに再計算?
引用:

    ActiveCell.Offset(2, 0).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.Offset(0, -1)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Calculate

このままだと無駄な処理になります。
また、ActiveCellは、カーソルがどこにあるのかわかっている場合だけ
意味を持ちます。
(1)の処理の結果が、
どこのセルが選択されているか、想定できますか?
 
このような観点で、コードをじっくり眺めてみましょう。
無駄、意味不明、意図不明を思われるコードが、い〜〜〜ぱい出てくると思います。
 

回答
投稿日時: 19/04/27 12:55:42
投稿者: simple

余り前進につながるようなコメントではないですが。
 

Range("C1").Select 
For i = 1 To 8 
    Selection.End(xlDown).Select 
Next i 
というのは、
C1からはじめて Ctrl+↓を8回繰り返すという意味かと思いますが、
特定の文字列で場所を特定するとか、なにか手がかりになるものは無いんですか?
また、各シートでレイアウトが共通しているなら、位置を決め打ちするとか、
何か手はないのですかね。
 
なにか、古地図の暗号を元に、宝の場所を探すようなコードで、可読性が低いですよね。
致し方ないのでしょうかね。
せめて、Rangeオブジェクト変数を使って、できるだけSelectしないことが
望ましいと思います。
 
レイアウトが提示されてでもいれば別ですが、
コードを元にレイアウトをこちらで想像して改善したコードを提示するようなことは、
お互いに生産的ではないので、期待されないほうがよいと思います。

回答
投稿日時: 19/04/27 15:32:20
投稿者: WinArrow
投稿者のウェブサイトに移動

simpleさんのレスの続き・・・というかヒントで↓のコードを整理すると
特定のセル範囲のデータを同一シートの「セルR2」に「値複写」ということですね?
再計算がて手動になっているため、再計算を途中に入れている。
 

引用:

    Range("c1").Select
        For i = 1 To 8
            Selection.End(xlDown).Select
        Next i
    ActiveCell.Offset(2, 0).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.Offset(0, -1)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Calculate
    Selection.Copy
    Range("R2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

 
改善点
(1)対象範囲を特定する方法
  先頭セルに名前を定義する 例:特定先頭
 
(2)SELECT排除
   前レスで使用した連続したセル範囲を取得するCurrentRegionを使う
   Range("特定先頭").CurrentRegion
   で、可視化&単純化できる
 
(3)再計算の局所化
   Calculateは、開いているすべてのブックが適用されます。
 複写対象だけに極小化しないと無駄な処理時間となる。
 
(4)複写方法
  コピペ方式を単純の「値」複写に切り替える
 
(1)〜(4)をつなげると
Dim 複写元 As Range
With Activesheet
    Set 複写元 = .Range("特定先頭").CurrentRegion
    複写元.Calculate
    .Range("R2").Resize(複写元.Rows.Count, 複写元.Columns.Count).Value = 複写元.Value
End With
というように13行→3行になります。
 

投稿日時: 19/05/07 15:37:25
投稿者: current

皆様、たくさんご教示いただきありがとうございました。少々お時間がかかりそうなので解決とさせていただきます。修正の際に再度ご質問させていただくことがあると思いますが、よろしくお願いいたします。