[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セル値の転記・半角変換・改行削除の速度』（おっちょこちょい）
データのあるファイルを開いたのちに範囲コピー(約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 ＞
（隠居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
隠居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
■１
＞コピーせずに範囲を配列化して全ての処理の後に転記先に書き込みした方が早いのでしょうか？
既にコメントがありますが少なくとも、↓のように【１セルずつ】書き込むよりは早いんじゃないでしょうか？
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
■２
同じく、既にコメントがありますが、表示形式の設定なども１度で済ましたほうが理屈上は高速化に寄与すると思います。
■３
さらに高速化に寄与するかは不明ですが、置換はReplace関数ではなくReplaceメソッドを使えば一括で処理できるとおもいます。
■４
ということを踏まえて私なりに整理するとこんな感じです。
興味があればどのくらい違うか試してみてください。
# 「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
（もこな２） 2023/03/14(火) 07:35:19
なるほど、転記元のシートを触るのではなく
マクロで転記先のシートに関数で転記してから値貼り付けですか・・・
セルの入力が倍になりますが、マクロ内で処理するより早くなるんですかね？
既に不満のない処理速度になっていますが、
有識者の助言なので試してみます。
もこな２さん＞
細かい指導、ありがとうございます。
コード的にこんなにスッキリするものなのですね・・・
自分の未熟さを痛感します。
上記したとおり既に不満がない処理速度になっていますが、
今後のためにも頂いたコードで修正して試してみます。
（おっちょこちょい） 2023/03/14(火) 08:01:34
（おっちょこちょい） 2023/03/14(火) 08:36:52
だいぶ違いますね・・・
ありがとうございます。
（おっちょこちょい） 2023/03/14(火) 08:39:50
■５
＞自動計算を手動に
出力するシートは少なくともコード上では値しか転記してないので、そのシートを参照する数式が組まれてないのであれば影響は無いような気がします、
■６
書いておいてなんですが、セルの書き換え回数を減らすという意味では↓のように、Replace関数を使いメモリ上で置換したほうが早いかもしれません。
二次元配列(x, y) = Replace(StrConv(二次元配列(x, y), vbNarrow), vbLf, Empty) （もこな２） 2023/03/14(火) 09:21:13
＞■６
変更してみたら１秒ないくらい遅くなってしまいました。
配列数が増えるとまた違うのかもしれませんが・・・
（おっちょこちょい） 2023/03/14(火) 12:33:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.