[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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
■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
提示のコードでは、1行ずつ書き込みしているので、結局書き込みは行数分発生するので高速化には貢献しません。
約10分もかかるということは、かなりのデータ量なのでしょう。
まず、配列化より前に、Findメソッドは非常に重い処理なので、これを別方法にするのを検討するが先決でしょう。
下記などを参考にしてみてください。
https://excel-ubara.com/excelvba4/EXCEL225.html
(hatena) 2022/06/22(水) 13:15
γさんのコードをお借りして、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
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
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
書き込みを配列で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.