[[20230313125123]] 『セル値の転記・半角変換・改行削除の速度』(おっちょこちょい) ページの最後に飛ぶ

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

 

『セル値の転記・半角変換・改行削除の速度』(おっちょこちょい)

データのあるファイルを開いたのちに範囲コピー(約40行×約40列)をして、
そのコピー先のセル値の半角変換・改行の削除をマクロで行っています。
その速度がかなり遅い(多分1分くらい)のですが、
コピーせずに範囲を配列化して全ての処理の後に転記先に書き込みした方が
早いのでしょうか?

分かる方がいらっしゃいましたらご教授お願いします。

Public Sub InportData()

    '原料在庫シートを更新
    '
    Dim Prop As New PropertyProcedure
    Dim wsItemData As Worksheet, wsGradeData As Worksheet

    '
    With Workbooks("原料搬入パレット作成表.xlsm")
        Set wsItemData = .Worksheets("原料データ")
        Set wsGradeData = .Worksheets("グレードデータ")
    End With

    '更新
    With Prop.ExpBook   'ファイルを開く←クラスモジュールに分けてあるので気にしないでください
        Dim r As Long, EndRow As Long, _
            c As Long, EndCol As Long
        Dim ExpAdr As String, InpAdr As String, ListAdr As String
        Dim ItemValue As Variant

        '原料データの更新
        With .Worksheets("原料在庫")
            EndRow = .Cells(.Rows.Count, "D").End(xlUp).Row - 7 'データの最終行を取得
            ExpAdr = "D5:E" & EndRow                            '転記元のアドレスを取得
            InpAdr = "C3:D" & (EndRow - 2)                      '転記先のアドレスを取得
            .Range(ExpAdr).Copy                                 '転記元をコピー
            wsItemData.Range(InpAdr).PasteSpecial xlPasteValues '転記先に値貼り付け
            Application.CutCopyMode = False
        End With

        'グレードデータの更新
        With .Worksheets("元データ")
            EndRow = .Cells(.Rows.Count, "A").End(xlUp).Row         'データの最終行を取得
            EndCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'データの最終列を取得
        End With

        With wsGradeData
            'グレードデータのシートの書式設定を初期化
            With .Cells
                .ClearContents          '値削除
                .WrapText = False       '折り返し表示なし
                .ShrinkToFit = False    '縮小表示なし
            End With
            'データの英数文字を半角に変換、セル内の改行を削除して転記
            For r = 1 To EndRow
                For c = 1 To EndCol
                    ItemValue = StrConv(Prop.ExpCell(r, c).Value, vbNarrow) '英数文字を半角に変換
                    ItemValue = Replace(ItemValue, vbLf, Empty)             '改行を削除
                    .Cells(r, c).Value = ItemValue                          '転記
                    With .Columns(c)
                        '数値セルの桁を設定
                        Select Case c
                            Case 17, 23, 29, 35, 37, 39
                                .NumberFormatLocal = "0.000"
                            Case Else
                                If ((c Mod 2) <> 0 And c <> 1) Then _
                                    .NumberFormatLocal = "0.0"
                        End Select
                        .AutoFit    '列幅の調整
                    End With
                Next c
                .Rows(r).AutoFit    '行幅の調整
            Next r
            .Rows(1).NumberFormatLocal = "G/標準"   '1行目のみ標準に戻す
        End With

        'グレード選択セルの入力規則を設定←ここも気にしないでください
        ValidateCell wsGradeData.Name

        'ファイルをマクロで開いた(読み込み専用)なら閉じる
        If .ReadOnly Then
            Application.DisplayAlerts = False
            .Close False
            Application.DisplayAlerts = True
        End If
    End With

End Sub

< 使用 Excel:Microsoft365、使用 OS:Windows10 >


かなり、ハイレベルなコードとお見受けいたします。
私にとっては暗号でしかありませんが。^^;
確かに、一セル毎に書き出すよりは、配列にしろ、レンジオブジェクト
にしろ、一括処理の方が、早いのではないかと、思います。

やってみなければ、解りませんが。。。( ̄▽ ̄)
でわ
m(__)m

(隠居Z) 2023/03/13(月) 13:26:39


 関数で(CLEANとかASCとか)欲しい結果があらかじめシート上に出る様に仕掛けておいて、
 そこから一気に値だけコピぺし直す。
                                ...という手もありそうですね。

(白茶) 2023/03/13(月) 13:34:34


 ちょっと抜き出してみるとですね
 こうなります

        With wsGradeData
            For r = 1 To EndRow
                For c = 1 To EndCol
                    With .Columns(c)
                        .NumberFormatLocal = "0.000"
                        .AutoFit 
                    End With
                Next c
            Next r
        End With

 wsGradeData.Columns(c)に対して、書式設定と行幅の調整を 「行数分」繰り返してます
 1列につき1回だけにすれば、ちょっと速くなると思います
(´・ω・`) 2023/03/13(月) 15:06:00

 同じシートで試してみましたが1〜3秒くらいでした。
 ファイルを開く際に時間がかかっているか、数式が多く入っていないでしょうか?
 一度ファイルの再計算を止めてみてはどうでしょう
(シオラ) 2023/03/13(月) 15:32:46

 データの変換内容は全部同じで一括でしたので、ループ処理ではなく
 Evaluateで変換してあげれば早いかもしれないです。
    With wsGradeData
        'グレードデータのシートの書式設定を初期化
        With .Cells
            .ClearContents          '値削除
            .WrapText = False       '折り返し表示なし
            .ShrinkToFit = False    '縮小表示なし
        End With
        '★ここの部分
        Dim fx As String
        Dim ItemValues As Variant  'ItemValue「s」として配列受取

        '一括変換 全角を半角、改行をなくす
        '式の作成
        fx = "=if(OFFSET(<RNG>,,)<>"""",substitute(asc(<RNG>),char(10),""""))"
        fx = Replace(fx, "<RNG>", InpAdr)

        Application.Calculation = xlCalculationManual
        '式の実行
        ItemValues = Evaluate(fx)
        '値の入力
        .Range(InpAdr) = ItemValues
        Application.Calculation = xlCalculationAutomatic

        'データの英数文字を半角に変換、セル内の改行を削除して転記
        For r = 1 To EndRow
            For c = 1 To EndCol
                'ここの変換工程をなくして、一括変換
                With .Columns(c)
 以下略
(稲葉) 2023/03/13(月) 16:48:49

皆様、コメントありがとうございます。
ひとつずつ試した結果、数秒で処理できるようになりました。
原因はデータ元のファイルに計算式が多く、立ち上げるのと処理中に時間がかかっていたようです。
プロシージャの先頭で自動計算を解除し、最後に戻すと早くなりました。
(ファイル起動のところではあまり変わらないので処理中の自動計算が1番問題だったのだと思います。)

隠居Zさん>
配列にするコードを書くと時間がかかるので今回は試していませんが、
体感でどれくらい変わるか試してみたいと思います。

白茶さん>
確かに先にエクセル関数で必要な変換を行えば早いかもですが、
データ元のファイルは別の方が使用されていて、変えたり関数入れたりするのは
あまりいい顔されないんです・・・
助言頂いたのにすみません。

(´・ω・`)さん>
仰ったとおり行列の幅調整は一気にやった方がいいと思い、
ループ内から外して

            Next r

            RowAdr = "1:" & EndRow                                  '行幅調整のアドレス
            ColAdr = .Cells(, EndCol).Address
            ColAdr = "$A:" & Mid(ColAdr, 1, InStrRev(ColAdr, "$") - 1)  '列幅調整のアドレス
            .Columns(ColAdr).AutoFit                                '列幅の調整
            .Rows(RowAdr).AutoFit                                   '行幅の調整
            .Rows(1).NumberFormatLocal = "G/標準"                   '1行目のみ標準に戻す
        End With
のような形にして一気に調整するようにしました。

シオラさん>
マクロのある本体のブックには計算式はありませんでしたが、
データ元のブックはてんこ盛りでした。
このブックの自動計算が問題だったようです。
自動計算を手動に変えれば早くなるのは知っていましたが、
データ元は読み取るだけで全くセル値を触りませんし、
自動計算は問題ないと思い込んでいました。
あと、過去に共有ブックが突発エラーで手動計算のままになって、
多数の方の別のブックが手動計算になってしまったことがあったので
少し躊躇しました。

稲葉さん>
そんな関数?があったんですね・・・知りませんでした。
今回は使っていませんがいろいろ試してみて、
今後のコードや今まで作ったマクロのブラッシュアップに使えればと思います。

皆様、ご教授頂き本当にありがとうございました。
(おっちょこちょい) 2023/03/13(月) 17:57:13


 もう終わっちゃったけど、修正お願いします。
 Offsetいらなかったのと、空白セルの時Falseになってしまうのでこっちで・・・
 誤:   fx = "=if(OFFSET(<RNG>,,)<>"""",substitute(asc(<RNG>),char(10),""""))"
 正:   fx = "=if(<RNG><>"""",substitute(asc(<RNG>),char(10),""""),"""")"

 白茶さんのおっしゃりたいことは
 sheets("グレードデータ").range(inpAdr).Formula = "CLEAN(ASC(元データ!A1))"
 sheets("グレードデータ").range(inpAdr).Value = sheets("グレードデータ").range(inpAdr).Value
 たぶんこんな感じじゃないですかね?
(稲葉) 2023/03/13(月) 18:07:47

話が終わっているようですが投稿しておきます。

■1
>コピーせずに範囲を配列化して全ての処理の後に転記先に書き込みした方が早いのでしょうか?
既にコメントがありますが少なくとも、↓のように【1セルずつ】書き込むよりは早いんじゃないでしょうか?

            For r = 1 To Prop.ExpBook.Worksheets("元データ").Cells(.Rows.Count, "A").End(xlUp).Row
                For c = 1 To Prop.ExpBook.Worksheets("元データ").Cells(1, .Columns.Count).End(xlToLeft).Column
                    ItemValue = StrConv(Prop.ExpCell(r, c).Value, vbNarrow) '英数文字を半角に変換
                    ItemValue = Replace(ItemValue, vbLf, Empty)             '改行を削除
                    Workbooks("原料搬入パレット作成表.xlsm").Worksheets("グレードデータ").Cells(r, c).Value = ItemValue  '転記
                Next c
            Next r

■2
同じく、既にコメントがありますが、表示形式の設定なども1度で済ましたほうが理屈上は高速化に寄与すると思います。

■3
さらに高速化に寄与するかは不明ですが、置換はReplace関数ではなくReplaceメソッドを使えば一括で処理できるとおもいます。

■4
ということを踏まえて私なりに整理するとこんな感じです。
興味があればどのくらい違うか試してみてください。

 # 「Prop.ExpCell」がどのシートなのか不明だったので「Prop.ExpBook.Worksheets("元データ")」と仮置きしました。
 # そのほかのシートも適宜修正してください。(いずれもコメントアウトさせています)

    Sub 抜粋()
        Dim 二次元配列 As Variant
        Dim x As Long, y As Long, c As Variant
        Dim bufRNG As Range

        'With Prop.ExpBook.Worksheets("元データ")
        With Worksheets("元データ")
            二次元配列 = .Range("A1", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
        End With

        For x = 1 To UBound(二次元配列, 1)
            For y = 1 To UBound(二次元配列, 2)
                二次元配列(x, y) = StrConv(二次元配列(x, y), vbNarrow)
            Next y
        Next x

        'With Workbooks("原料搬入パレット作成表.xlsm").Worksheets("グレードデータ")
        With Worksheets("グレードデータ").Range("A1").Resize(UBound(二次元配列, 1), UBound(二次元配列, 2))
                .Value = 二次元配列
                .Replace vbLf, Empty

                Set bufRNG = .Cells(1, 3)
                For c = 5 To UBound(二次元配列, 2) Step 2
                    Set bufRNG = Union(bufRNG, .Cells(1, c))
                Next c
                Intersect(.Cells, bufRNG.EntireColumn).NumberFormatLocal = "0.0"

                Set bufRNG = .Cells(1, 17)
                For Each c In Array(17, 23, 29, 35, 37, 39)
                    Set bufRNG = Union(bufRNG, .Cells(1, c))
                Next
                Intersect(.Cells, bufRNG.EntireColumn).NumberFormatLocal = "0.000"

                .Rows(1).NumberFormatLocal = "G/標準"
                .Rows.AutoFit
                .Columns.AutoFit
        End With
    End Sub

(もこな2) 2023/03/14(火) 07:35:19


稲葉さん>
修正ありがとうございます。

なるほど、転記元のシートを触るのではなく
マクロで転記先のシートに関数で転記してから値貼り付けですか・・・
セルの入力が倍になりますが、マクロ内で処理するより早くなるんですかね?

既に不満のない処理速度になっていますが、
有識者の助言なので試してみます。

もこな2さん>
細かい指導、ありがとうございます。

コード的にこんなにスッキリするものなのですね・・・
自分の未熟さを痛感します。
上記したとおり既に不満がない処理速度になっていますが、
今後のためにも頂いたコードで修正して試してみます。
(おっちょこちょい) 2023/03/14(火) 08:01:34


もこな2さんのコードを組みなおして比べると、
約3.5秒早くなりました。

(おっちょこちょい) 2023/03/14(火) 08:36:52


元のコード→約1分
自動計算を手動に+幅調整を一括→6.3秒
もこな2さんのコードを修正したもの→3.7秒

だいぶ違いますね・・・
ありがとうございます。
(おっちょこちょい) 2023/03/14(火) 08:39:50


報告ありがとうございました。
ちょっと的外れかもしれませんが思ったことなど追加で。

■5
>自動計算を手動に
出力するシートは少なくともコード上では値しか転記してないので、そのシートを参照する数式が組まれてないのであれば影響は無いような気がします、

■6
書いておいてなんですが、セルの書き換え回数を減らすという意味では↓のように、Replace関数を使いメモリ上で置換したほうが早いかもしれません。

 二次元配列(x, y) = Replace(StrConv(二次元配列(x, y), vbNarrow), vbLf, Empty)
(もこな2) 2023/03/14(火) 09:21:13

>■5
マクロを実行するブックには全く計算式を使用していないので、
自分も自動→手動では変わらないんじゃないかと最初は思いましたが全然違いましたね。
転記元のブックには計算式がてんこ盛りでシート数も多く、マクロもあるので
内部で何かしらやっているのかもしれません。

>■6
変更してみたら1秒ないくらい遅くなってしまいました。
配列数が増えるとまた違うのかもしれませんが・・・
(おっちょこちょい) 2023/03/14(火) 12:33:08


コメント返信:

[ 一覧(最新更新順) ]


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