[[20190313135859]]　『高速処理するには…。』（マイマイ）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『高速処理するには…。』（マイマイ）

ユーザーフォームに集計期間とモール名と手数料を入力し、集計ボタンを押す。
するとSheet"出力データ"に結果が出る、というマクロを組んでいます。
望んだ通りの結果が出るのですが、処理が重く1分ほどかかってしまいます。
高速処理化したいのですが、どのように手直しすればいいか分かりません。

Sheet"売上高"にはA〜Wまでデータが入っています。
Sheet"出力データ"の上から5行目までは計算式などが入っています。
列数は変わらず、行数が毎回変化します。

流れとしては以下の通りです。
罫線をクリア → 各項目の転写 → ソートA＞M → 小計 → 罫線を引く
※転写の部分は作っていただきました。 

    Private Sub CommandButton3_Click()
        '集計クリック
        '画面の再描画/自動計算を停止
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        '罫線クリア
        Rows("5:5").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        '入力項目のチェック
        Dim i As Long
        Dim lst As String
        Dim msg As String
        If Not IsDate(TextBox1.Value) Then msg = msg & vbCrLf & "集計期間に日付が入力されていません。"
        If Not IsDate(TextBox2.Value) Then msg = msg & vbCrLf & "集計期間に日付が入力されていません。"
        If Not IsNumeric(TextBox3.Value) Then msg = msg & vbCrLf & "店舗手数料に数値が入力されていません。"
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) = True Then lst = lst & Chr(2) & ListBox1.List(i)
        Next i
        If lst = "" Then msg = msg & vbCrLf & "対象店舗が選択されていません。"
        If msg <> "" Then
            MsgBox "未入力または誤った値が入力されています。" & msg
        Else
            lst = Mid$(lst, 2)
            With Sheets("検索")
                .Cells.ClearContents
                .[A1:B1] = [{"日付";"日付"}]
                .[A2] = ">=" & TextBox1.Value
                .[B2] = "<=" & TextBox2.Value
                .Range("D1").Resize(UBound(Split(lst, Chr(2))) + 1).Value = Application.Transpose(Split(lst, Chr(2)))
                .Range("C2").Formula = "=COUNTIF($D:$D,売上高!D2)"
            End With
            Sheets("売上高").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("検索").Range("A1:C2"), CopyToRange:=Sheets("集計").Range("A5:R5"), Unique:=False
            With Sheets("集計")
                .Activate
                .[K2] = TextBox1.Value
                .[L2] = "〜"
                .[M2] = TextBox2.Value
                .[C3] = lst
                .[E3] = TextBox3.Value
            End With
' ソート Macro
Dim lastRow As Long, lastCol As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
lastCol = Cells(5, Columns.Count).End(xlToLeft).Column 
Range(Cells(5, "A"), Cells(lastRow, lastCol)).Sort key1:=Range("A5"), order1:=xlAscending, _
key2:=Range("M5"), Order2:=xlDescending, Header:=xlYes
            With ActiveWorkbook.Worksheets("集計").Sort
        .SetRange Range(Cells(5, "A"), Cells(lastRow, lastCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
' 小計 Macro
lastRow = Cells(Rows.Count, "A").End(xlUp).Row 
lastCol = Cells(5, Columns.Count).End(xlToLeft).Column 
    Range(Cells(5, "A"), Cells(lastRow, lastCol)).Select
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 6, 7, _
        8, 9, 10, 11, 12), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
     Cells.ClearOutline
' 罫線 Macro
lastRow = Cells(Rows.Count, "A").End(xlUp).Row 
lastCol = Cells(5, Columns.Count).End(xlToLeft).Column
Range(Cells(5, "A"), Cells(lastRow, lastCol)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ThemeColor = 9
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With


    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ThemeColor = 9
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 9
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ThemeColor = 9
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 9
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ThemeColor = 9
        .TintAndShade = -0.249946592608417
        .Weight = xlHairline
'画面の再描画/自動計算を再開
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
    End With
            Unload Me


        End If


    End Sub

＜ 使用 Excel：unknown、使用 OS：unknown ＞

 まるで自分で組んだかのような口ぶりですねぇ
[[20190226094805]]　『売上高からデータを絞込み、データ出力がしたいで』（マイマイ）　>>BOT


 前回の質問に続けてもらえればよかったと思うのですが。
（稲葉） 2019/03/13(水) 14:40
＞稲葉様
前回はありがとうございます。
お陰様で大分形になってきました。
私が作ったのはソートの部分とか罫線とかの簡単な部分です。
すみません。そんなつもりはなく一応明記していたつもりだったのですが。
＞＞※転写の部分は作っていただきました。
ご不快な思いをさせてしまい、申し訳ありません。

稲葉様に作っていただいた部分ではなく、私が作った部分が何度も同じ処理が出てくるのでここに問題があると思って別件で立てさせてもらいました。
（マイマイ） 2019/03/13(水) 14:51

 たぶん、問題があるのは私のほうだと思います。


 ＞                .Range("C2").Formula = "=COUNTIF($D:$D,売上高!D2)"
 ＞            Sheets("売上高").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("検索").Range("A1:C2"), CopyToRange:=Sheets("集計").Range("A5:R5"), Unique:=False
 こちらのコードで処理が重くなっているような気がしました。


 店名のor条件検索ですので、手抜きせずに作り変えます。
 他の見直しできそうなところもやりますので、少々お待ちください。

（稲葉） 2019/03/13(水) 14:58

 もう一点
 ご自身で記述されたコードに、シート名が一切ないのですが、どのシートが対象ですか？
（稲葉） 2019/03/13(水) 15:01
＞稲葉様
いつもありがとうございます。
Sheetは"集計"です。
集計シートにフォームコントロールボタンをつけてあって、ボタンを押すとあの入力フォームが立ち上がるようにしてあります。
なので、集計シートでしか処理しないのでシート指定をしてないのですが、やはり指定した方がいいのでしょうか。

前回のマクロ本当に感激しました。
5行目の各項目名を参照して転写してくれるので、項目の入れ替えも容易で自由度の高さに驚きました。
テーブル設定のおかげで容量も軽くなりましたし、本当に助かってます。

（マイマイ） 2019/03/13(水) 15:15

 コンパイルは通ったけど、最初に作った時とセル配置が違うから、テストしてません。
 重い原因は私のところと、おそらく小計機能だと思います。
 小計実行する前にStop入れましたので、そこまでが早ければ、あとは小計機能をピボットに置き換えるほうが
 懸命だと思います。


    Option Explicit
    Private Sub CommandButton3_Click()
        Dim i As Long
        Dim lst As String, n As Long
        Dim msg As String
        Dim rng As Range '出力後の書式設定に使用
        '入力項目のチェック
        If Not IsDate(TextBox1.Value) Then msg = msg & vbCrLf & "集計期間に日付が入力されていません。"
        If Not IsDate(TextBox2.Value) Then msg = msg & vbCrLf & "集計期間に日付が入力されていません。"
        If Not IsNumeric(TextBox3.Value) Then msg = msg & vbCrLf & "店舗手数料に数値が入力されていません。"
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) = True Then lst = lst & Chr(2) & ListBox1.List(i)
        Next i
        If lst = "" Then msg = msg & vbCrLf & "対象店舗が選択されていません。"
        If msg <> "" Then
            MsgBox "未入力または誤った値が入力されています。" & msg
        Else
            '集計クリック
            '画面の再描画/自動計算を停止
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            '罫線クリア
            Sheets("集計").Range("A5:A" & Rows.Count).Borders = False
            lst = Mid$(lst, 2)
            n = UBound(Split(lst, Chr(2))) + 1
            With Sheets("検索")
                .Cells.ClearContents
                .[A1:B1] = [{"日付";"日付"}]
                .[C1] = "モール"
                .Range("C2").Resize(n).Value = Application.Transpose(Split(lst, Chr(2)))
                .Range("A2:A" & n).Value = ">=" & TextBox1.Value
                .Range("B2:B" & n).Value = "<=" & TextBox2.Value
            End With
            Sheets("売上高").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("検索").Range("A1:C" & n), CopyToRange:=Sheets("集計").Range("A5:R5"), Unique:=False
            With Sheets("集計")
                .Activate
                .[K2] = TextBox1.Value
                .[L2] = "〜"
                .[M2] = TextBox2.Value
                .[C3] = lst
                .[E3] = TextBox3.Value
            ' ソート Macro
                Set rng = .Range(.Cells(Rows.Count, "A").End(xlUp), .Cells(5, Columns.Count).End(xlToLeft))
                With .Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=.Range("A5")
                    .SortFields.Add Key:=.Range("M5"), Order:=xlDescending
                    .SetRange rng
                    .Header = xlYes
                    .Apply
                End With
                ' 小計 Macro
                'この部分はピボットテーブルのほうがいいかも知れない。
                Stop
                rng.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 6, 7, 8, 9, 10, 11, 12), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
                .Cells.ClearOutline
                Set rng = .Range(.Cells(Rows.Count, "A").End(xlUp), .Cells(5, Columns.Count).End(xlToLeft))
                ' 罫線 Macro
                With rng.Borders
                    .LineStyle = xlContinuous
                    .ThemeColor = 9
                    .TintAndShade = -0.25
                    .Weight = xlThin
                End With
                rng.Borders(xlInsideHorizontal).Weight = xlHairline
                '画面の再描画/自動計算を再開
            End With
            Application.Calculation = xlCalculationAutomatic
            Application.ScreenUpdating = True
            Unload Me
        End If
    End Sub
（稲葉） 2019/03/13(水) 15:45

 ２か所訂正
 ＞                .Range("A2:A" & n).Value = ">=" & TextBox1.Value
 ＞                .Range("B2:B" & n).Value = "<=" & TextBox2.Value
 こちらを以下に置き換えてください
                .Range("A2").Resize(n).Value = ">=" & TextBox1.Value
                .Range("B2").Resize(n).Value = "<=" & TextBox2.Value
（稲葉） 2019/03/13(水) 15:47
＞ '罫線クリア
＞ Sheets("集計").Range("A5:A" & Rows.Count).Borders = False

ここのところで実行時エラー423が出ます。
シート名も合ってますし、スペルミスもないように思うのですが。
（マイマイ） 2019/03/13(水) 16:06

すみません。エラー438の書き間違いです。
オブジェクトは、このプロパティまたはメソッドをサポートしていません。
（マイマイ） 2019/03/13(水) 16:07
  False をxlnoneに直してもらえますか？

（稲葉） 2019/03/13(水) 16:56

同じエラーが返ってきます。

ちなみに一度罫線クリアの部分だけ元に戻して実行してみたら、参照まではめちゃくちゃ早かったです！
おっしゃる通り小計部分がどうしても時間がかかるようなのでピボットも考えてみます。
（マイマイ） 2019/03/13(水) 17:04

 あ、ボーダーのプロパティーが抜けてるからえらーだ
 ラインスタイル = Falseでどうでしょう？


 ビボットなら、いちいち作らず、データ範囲大きめに設定して
 範囲内のデータが書き変わったときだけ、リクエリすれば大丈夫です
（稲葉） 2019/03/13(水) 18:26
稲葉様
＞ Sheets("集計").Range("A5:A" & Rows.Count).Borders.LineStyle = False
これだとエラーは出ませんでしたが、クリア範囲が狭かったです。
ストップが入る時に、転写されてる部分はクリアされているのですが、前回結果分の罫線が下にずれていって、残ったままです。
すみません。説明が下手で・・・

それから転写の際、モールと日付の両方とも絞込みが効いてません。
検索シートに日付とモールは正確に表示されています。
（マイマイ） 2019/03/14(木) 10:13

 Sheets("集計").Range("A5:AA" & Rows.Count).Borders.LineStyle = False 
 A列しか範囲してなかった。~~ 訂正箇所　すません。


 そしたら、検索部分は以前のコードに直してもらえますか？
 そのうえで、小計前までの速度をStopで体感してもらってから修正でもよいかなと。

（稲葉） 2019/03/14(木) 10:23

稲葉様

罫線バッチリです。
速度も素晴らしいです。ありがとうございます！
小計はピポットの方向で考えてみます。
（マイマイ） 2019/03/14(木) 11:43

コメント返信：

[ 一覧(最新更新順) ]

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.