Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4245 / 76807

←次へ　｜　前へ→


	【78188】Re:エクセル内のデータ転送に関して

β - 16/5/20(金) 20:10 -


	引用なし

	パスワード

▼TODD さん：

別案もアップしておきます。
２回目、３回目の条件は、先にコメントした通りです。
下記の Test2 が、TODDさんがループで処理しようとしておられた流れになるかと思います。
Test3 は、同じループなら、効率を考えて、一工夫したもの。

F列等の件数が少なければアップ済みの Test でも問題ないかと思いますが
件数が膨大ならTest3ですね。
で、残念ながら、Test2 は、最も効率の悪い方式になります。

Sub test2()
　　Dim col As Long
　　Dim i As Long
　　Dim x As Long
　　Dim mx As Long
　　
　　Application.ScreenUpdating = False
　　
　　mx = Range("A" & Rows.Count).End(xlUp).Row
　　col = Cells(1, Columns.Count).End(xlToLeft).Column
　　
　　With Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Resize(, 3)
　　　　For i = 1 To .Rows.Count
　　　　　　.Cells(i, 2).Resize(, 2).ClearContents
　　　　　　For x = 1 To mx
　　　　　　　　If .Cells(i, 1).Value = Cells(x, "A").Value Then
　　　　　　　　　　.Cells(i, 2).Value = Cells(x, "B").Value
　　　　　　　　　　.Cells(i, 3).Value = Cells(x, "C").Value
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
　　
End Sub

Sub test3()
　　Dim dic As Object
　　Dim c As Range
　　Dim col As Long
　　Dim x As Long
　　Dim v As Variant
　　Dim w As Variant
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
　　　　dic(c.Value) = c.Offset(, 1).Resize(, 2).Value
　　Next
　　
　　col = Cells(1, Columns.Count).End(xlToLeft).Column
　　v = Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Value
　　ReDim Preserve v(1 To UBound(v, 1), 1 To 3)
　　
　　For x = 1 To UBound(v, 1)
　　　　If dic.exists(v(x, 1)) Then
　　　　　　w = dic(v(x, 1))
　　　　　　v(x, 2) = w(1, 1)
　　　　　　v(x, 3) = w(1, 2)
　　　　End If
　　Next
　　
　　Cells(1, col).Resize(UBound(v, 1), UBound(v, 2)).Value = v
　　
End Sub

0 hits

▼

【78185】エクセル内のデータ転送に関して TODD 16/5/20(金) 8:24