[[20220622110655]] 『vbaの配列で別シートへの転記』(おすぎ) ページの最後に飛ぶ

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

 

『vbaの配列で別シートへの転記』(おすぎ)

転記先シートのB列の値を大元シートのBM列から探し該当があった場合に、
大元シートのBB〜BE列の情報を転記先シートのBM〜BP列に転記したいです。
配列が早いと聞いたので、いろいろ試行錯誤しましたが、
ーーーーーーーーーーーーーで囲った転記の部分がうまくいきません。
ここをどのように変更したらよいかどなたか教えてください。

Dim c As Range, ar As Range
Dim myArray As Variant

MaxRow = Sheets("転記先").Cells(Rows.Count, 1).End(xlUp).Row
MaxRow2 = Sheets("大元").Cells(Rows.Count, 1).End(xlUp).Row

  For Each c In Sheets("転記先").Range("B2" & ":B" & MaxRow).SpecialCells(2) 'c = 検索範囲
    For Each ar In Array(sheets("大元").Range("BM2" & ":BM" & MaxRow2))
      Set f = ar.Find(c.Value, , , xlWhole) 
      If Not f Is Nothing Then flg = True
    Next ar

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
'転記情報を配列に格納

    myArray = Array(sheets("大元").Range("BM2" & ":BM" & MaxRow2))
    If flg Then
      c.Offset(0, 65).Resize(, 4).Value = myArray.Offset(, -11).Resize(, 4)
    Else
    End If
  Next
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

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


 動作確認していないので恐縮ですが、参考にしてください。

 Sub test()
     Dim c As Range, ar As Range
     Dim f As Range
     Dim MaxRow As Long, MaxRow2 As Long

     MaxRow = Sheets("転記先").Cells(Rows.Count, 1).End(xlUp).Row
     MaxRow2 = Sheets("大元").Cells(Rows.Count, 1).End(xlUp).Row
     Set ar = Sheets("大元").Range("BM2" & ":BM" & MaxRow2)

     For Each c In Sheets("転記先").Range("B2" & ":B" & MaxRow).SpecialCells(2)    'c = 検索範囲
         Set f = ar.Find(c.Value, , , xlWhole)
         If Not f Is Nothing Then
             Sheets("転記先").Cells(c.Row, "BM").Resize(, 4).Value _
                 = Sheets("大元").Cells(f.Row, "BB").Resize(, 4).Value
         End If
     Next
 End Sub

 配列にすると高速化するというのは、まとめて書き込むので早くなるということであって、
 行単位でコピー処理する前提では余り関係がないと思います。上記で特に問題とは思いません。

(γ) 2022/06/22(水) 11:43


■1
>配列が早いと聞いたので、いろいろ試行錯誤しましたが、
どのようなことを試行錯誤しましたか?
コードでうんうん唸るくらいなら、普通にコピー&ペーストで対処するわけにはいかないのですか?

■2
↓は1セルを対象に検索することになると思うのですが狙い通りですか?
(1行ずつアタックしていくにしても、検索範囲は"BM2:BM" & MaxRow2 でよくないですか?)

 Set f = ar.Find(c.Value, , , xlWhole)

また、省略している引数は前回値が承継されますが問題ないのですか?
さらに、検索はBM2セルの【次のセル】であるBM3から始まりますが問題ありませんか?

■3
2重ループで頑張る作戦のようですが、

 (1)転記先シートのBM〜BP列にVLOOKUPで大元シートを参照する数式を記入する
 (2)(1)を値化する
というアプローチもあるとおもいます。
現状の案にこだわらず柔軟に考えると道が開けるかもしれません。
 ※Office365ならばXLOOKUPも使えますね。

(もこな2 ) 2022/06/22(水) 12:00


γさんご返信ありがとうございます。
教えていただいたコードで処理時間を計測したところ約10分かかりました。
(ScreenUpdatingプロパティもFalseにしました)
もう少し短くするにはどのようにすればよいでしょうか。
(おすぎ) 2022/06/22(水) 12:48

配列を使って高速化するのは、セルにアクセスする(読み込み、書き込み)のが重い処理なので、その回数をなるべく減らすことができるからです。
セル範囲を配列に格納、配列で処理、処理後に配列をセル範囲に書き込み、とすると読み込み1回、書き込み1回ですみます。(読み込みはそれほど重くないので、書き込みのみ配列で1回にするということもあります。)

提示のコードでは、1行ずつ書き込みしているので、結局書き込みは行数分発生するので高速化には貢献しません。

約10分もかかるということは、かなりのデータ量なのでしょう。
まず、配列化より前に、Findメソッドは非常に重い処理なので、これを別方法にするのを検討するが先決でしょう。

下記などを参考にしてみてください。

https://excel-ubara.com/excelvba4/EXCEL225.html

(hatena) 2022/06/22(水) 13:15


10分はかかり過ぎですかね。
行数はどのくらいですか。
処理の最初で手動計算にし、
最後に自動に戻す処理を入れたらどうなりますか?
(γ) 2022/06/22(水) 13:48

 γさんのコードをお借りして、Findメソッドの部分を Match関数での検索に置き換えたものです。

 Sub test()
     Dim c As Range, ar As Range
     Dim m As Long
     Dim MaxRow As Long, MaxRow2 As Long
     MaxRow = Sheets("転記先").Cells(Rows.Count, 1).End(xlUp).Row
     MaxRow2 = Sheets("大元").Cells(Rows.Count, 1).End(xlUp).Row
     Set ar = Sheets("大元").Range("BM2" & ":BM" & MaxRow2)
     For Each c In Sheets("転記先").Range("B2" & ":B" & MaxRow).SpecialCells(2)    'c = 検索範囲
         On Error Resume Next
         m = 0
         m = WorksheetFunction.Match(c.Value, ar, 0)
         On Error GoTo 0
         If m > 0 Then
             Sheets("転記先").Cells(c.Row, "M").Resize(, 4).Value _
                 = Sheets("大元").Cells(m + 1, "BB").Resize(, 4).Value
         End If
     Next
 End Sub

 これで改善されませんか。
 これでご希望の速度がでないなら、配列とか、Dictionaryでの検索とか、XLOOKUPとか、いろいろ検討されるといいでしょう。

(hatena) 2022/06/22(水) 13:49


FindメソッドではなくMatch関数で〜と書こうと思ったらhatenaさんに先を越されたので、Findメソッドを使う例など。
(いずれにせよ、繰り返しになりますが1セルずつチェックしていくのは効率悪いと思います。)

    Sub 名もなきマクロ()
        Dim MaxRow As Long, MaxRow2 As Long
        Dim MyRNG As Range, tmpRNG As Range

        Stop 'ブレークポイントの代わり

        With Sheets("大元")
            MaxRow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
            If MaxRow2 < 2 Then
                MsgBox .Name & " にデータがありません" & vbLf & "処理を中止します"
                Exit Sub
            End If
        End With

        With Sheets("転記先")
            MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            If MaxRow < 2 Then
                MsgBox .Name & " にデータがありません" & vbLf & "処理を中止します"
                Exit Sub
            End If

            For Each MyRNG In .Range("B2:B" & MaxRow)
                Set tmpRNG = Sheets("大元").Range("BM2:BM" & MaxRow2).Find(What:=MyRNG, After:=Sheets("大元").Cells(MaxRow2, "BM"), LookIn:=xlValues, Lookat:=xlWhole)
                Stop 'ブレークポイントの代わり
                If Not tmpRNG Is Nothing Then
                    Stop 'ブレークポイントの代わり
                    .Cells(MyRNG.Row, "BM").Resize(, 4).Value = Intersect(tmpRNG.EntireRow, tmpRNG.Parent.Range("BB:BE")).Value
                End If
            Next MyRNG
        End With
    End Sub

(もこな2 ) 2022/06/22(水) 14:44


 書き込みを配列で1回ですませるようにしたものです。
 画面更新と自動計算の抑制も追加しておきました。

 Sub test()
     Application.ScreenUpdating = False
     Application.Calculation = xlCalculationManual

     Dim c As Range, ar As Variant
     Dim m As Long
     Dim MaxRow As Long, MaxRow2 As Long
     Dim arSaki(), arRow
     MaxRow = Sheets("転記先").Cells(Rows.Count, 1).End(xlUp).Row
     ReDim arSaki(1 To MaxRow - 1, 1 To 4) '転記用配列

     MaxRow2 = Sheets("大元").Cells(Rows.Count, 1).End(xlUp).Row
     Set ar = Sheets("大元").Range("BM2" & ":BM" & MaxRow2)
     For Each c In Sheets("転記先").Range("B2" & ":B" & MaxRow).SpecialCells(2)    'c = 検索範囲
         On Error Resume Next
         m = 0
         m = WorksheetFunction.Match(c.Value, ar, 0)
         On Error GoTo 0
         If m > 0 Then
             arRow = Sheets("大元").Cells(m + 1, "BB").Resize(, 4).Value
             arSaki(c.Row - 1, 1) = arRow(1, 1)
             arSaki(c.Row - 1, 2) = arRow(1, 2)
             arSaki(c.Row - 1, 3) = arRow(1, 3)
             arSaki(c.Row - 1, 4) = arRow(1, 4)
         End If
     Next
     Sheets("転記先").Cells(2, "BM").Resize(MaxRow - 1, 4).Value = arSaki

     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
 End Sub

(hatena) 2022/06/22(水) 15:30


ちまちまと書いていたら、これまたモロ被りでした・・・・・
とりあえず投稿しておきます。
    Sub 配列研究()
        Dim MaxRow As Long, MaxRow2 As Long
        Dim 二次元配列 As Variant
        Dim 発見行 As Variant
        Dim i As Long

        With Sheets("大元")
            MaxRow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
            If MaxRow2 < 2 Then
                MsgBox .Name & " にデータがありません" & vbLf & "処理を中止します"
                Exit Sub
            End If
        End With

        With Sheets("転記先")
            MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            If MaxRow < 2 Then
                MsgBox .Name & " にデータがありません" & vbLf & "処理を中止します"
                Exit Sub
            End If

            二次元配列 = .Range("BM2:BP" & MaxRow).Value

            For i = 1 To UBound(二次元配列, 1)
                発見行 = Application.Match(.Cells(i + 1, "B").Value, Sheets("大元").Columns("BM"), 0)
                If Not IsError(発見行) Then
                    二次元配列(i, 1) = Sheets("大元").Cells(発見行, "BB").Value
                    二次元配列(i, 2) = Sheets("大元").Cells(発見行, "BC").Value
                    二次元配列(i, 3) = Sheets("大元").Cells(発見行, "BD").Value
                    二次元配列(i, 4) = Sheets("大元").Cells(発見行, "BE").Value
                End If
            Next i

            .Range("BM2:BP" & MaxRow).Value = 二次元配列
        End With
    End Sub

(もこな2 ) 2022/06/22(水) 16:02


ご返信ありがとうございます。
大元シートは約6万行、一覧表シートは約5万行あります。
hatenaさんの書き込みを配列で1回ですませるコードの
最初に手動計算→最後に自動に戻すコードを入れて、
教えていただいたコードをそれぞれ試したところ、5分強時間がかかりました。
(強制退社になってしまったため、もこな2さんのものが試せておらず申し訳ございません。)

Dictionaryがあまりよく分かっていないため、
とりあえず試しに大元シートBB列1列の情報だけを一覧表のBQ列に転記するコードを書いてみました。
が今度は、配列から一括出力する際に
実行時エラー'1004
アプリケーション定義またはオブジェクト定義のエラーとなってしまいました。
途中までは正しく出力されており、エラーで止まった検索値は、
Dictionaryにも登録済で、検索範囲に含まれている値です。
データ内に頭に"="が付いていたものがありましたので削除しましたが、
結果は変わらずです。
転記したいデータ(日付)が異常な状態になっている等でしょうか。

Sub Dictionaryを試す()

Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("大元")
Set ws2 = Sheets("一覧表")

Dim l
Dim マスタ下端行
With ws1
 マスタ下端行 = .Cells(Rows.Count, 1).End(xlUp).Row
 Dim 参照範囲
 参照範囲 = .Range(.Cells(1, 1), .Cells(マスタ下端行, 65))
End With

For l = 2 To マスタ下端行
 If dic.Exists(参照範囲(l, 65)) = False Then
 dict.Add Key:=参照範囲(l, 65), Item:=参照範囲(l, 54)
 End If
Next l

With ws2
 Dim 伝票下端行
 伝票下端行 = .Cells(Rows.Count, 1).End(xlUp).Row
 Dim 伝票範囲
 伝票範囲 = .Range(.Cells(1, 1), .Cells(伝票下端行, 69)).Value
 Dim i
 伝票範囲(1, 69) = "YJコード"

 For i = 2 To 伝票下端行
  伝票範囲(i, 69) = dictJANYJ.Item(伝票範囲(i, 2))
 Next i
 .Range(.Cells(1, 1), .Cells(伝票下端行, 69)) = 伝票範囲
End With

End Sub

(おすぎ) 2022/06/22(水) 18:28


 なんか最初の質問と、シート名も変わっているし、よくわかりません。
最初の情報をもとにサンプルを作成して動作確認しているので、途中から変更されても混乱します。

 ということで、最初の情報をもとにして、Dictionary を使った場合のコード例です。
読み込みも配列を使ってセルアクセスを減らしてます。

 Sub test_Dictionary()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws1 As Worksheet, ws2 As Worksheet, MaxRow1 As Long, MaxRow2 As Long
    Set ws1 = Sheets("大元")
    Set ws2 = Sheets("転記先")
    MaxRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    MaxRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

    Dim ary1S()
    ary1S = ws1.Range("BM2:BM" & MaxRow1).Value '検索範囲配列

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim i As Long
    For i = MaxRow1 - 1 To 1 Step -1
        dic(ary1S(i, 1)) = i
    Next

    Dim ary1()
    ary1 = ws1.Range("BB2:BE" & MaxRow1).Value     '元配列
    Dim ary2()
    ReDim ary2(1 To MaxRow2 - 1, 1 To 4)        '転記先配列

    Dim ary2K(), j As Long
    ary2K = ws2.Range("B2:B" & MaxRow2).Value '転記先検索値配列
    For j = 1 To MaxRow2 - 1
        If dic.Exists(ary2K(j, 1)) Then
            i = dic(ary2K(j, 1))
            ary2(j, 1) = ary1(i, 1)
            ary2(j, 2) = ary1(i, 2)
            ary2(j, 3) = ary1(i, 3)
            ary2(j, 4) = ary1(i, 4)
        End If
    Next
    ws2.Cells(2, "BM").Resize(MaxRow2 - 1, 4).Value = ary2

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 End Sub

(hatena) 2022/06/22(水) 23:09


大元6万行、転記先6万行のデータを作成して、速度を計測してみました。

書き込みを配列で1回ですませるコードで149秒かかりました。
思ったより遅いですね。

Dictionary版だと、なんと1.6秒でした。
やはり、検索関係は、Dictionaryが最強ですかね。

(hatena) 2022/06/23(木) 00:55


コメント返信:

[ 一覧(最新更新順) ]


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