| |
▼kiki さん：
なぁるほど。そういう要件だったんだ。
じゃぁ、そちらのコードの添削は、この板の回答者さんにおまかせして
あちらで回答したコードを踏まえて以下。データ量が多ければ効果ありかな？
参考まで。
Sub Sample()
Dim c As Range
Dim v() As Variant
Dim keyV() As String
Dim b() As Variant
Dim cols As Long
Dim j As Long
Dim dic As Object
Dim sh1 As Worksheet
Dim cnt As Long
Dim fIdx As Long
Dim mIdx As Long
Dim w As Variant
Dim n As Long
Set dic = CreateObject("Scripting.Dictionary")
Set sh1 = Sheets("Sheet1")
fIdx = 1 '転記用配列行カウンター
ReDim v(1 To Rows.Count) '転記用配列を最大行で準備
ReDim keyV(1 To Rows.Count, 1 To 1) 'キー列用配列
With Sheets("Sheet1")
'シート１の列数取得
cols = .UsedRange.Cells(.UsedRange.Cells.Count).Column
ReDim b(1 To 1, 1 To cols) 'シート１にない場合の転記行スケルトン
End With
With Sheets("Sheet2")
'シート２のA1からA列のデータ最終行までのセルを１つずつ取り出す
For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
'シート２のキーの重複は無視（処理しない）
If Not dic.exists(c.Value) Then
'シート１のD列に、その値があるかどうか
cnt = WorksheetFunction.CountIf(sh1.Columns("D"), c.Value)
dic(c.Value) = Array(fIdx, cnt, 0)
If cnt > 0 Then
fIdx = fIdx + cnt 'シート２にあれば
Else
v(fIdx) = b 'なければ行スケルトン
keyV(fIdx, 1) = c.Value 'キー列
mIdx = fIdx '配列セット行の最大数
fIdx = fIdx + 1
End If
End If
Next
End With
With Sheets("Sheet1")
'シート1のD1からD列のデータ最終行までのセルを１つずつ取り出す
For Each c In .Range("D1", .Range("D" & .Rows.Count).End(xlUp))
'もし辞書にあれば（シート２にあれば）１行分のイメージを配列に格納
If dic.exists(c.Value) Then
w = dic(c.Value)
n = w(0) + w(2)
v(n) = c.EntireRow.Resize(, cols).Value
'配列セット行の最大値
mIdx = WorksheetFunction.Max(n, mIdx)
w(2) = w(2) + 1
dic(c.Value) = w
If w(2) = 1 Then keyV(n, 1) = c.Value 'キー列用配列
End If
Next
End With
With Sheets("Sheet2")
Cells.ClearContents '最初に転記領域のクリア
.Range("A1").Resize(mIdx).Value = keyV 'キー列セット
ReDim Preserve v(1 To mIdx) '転記用配列を実際の行数分に圧縮
.Range("C1").Resize(mIdx, cols).Value = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))
.Select
End With
MsgBox "転記終了"
End Sub
|
|
ぶらっと
- 12/8/7(火) 10:09 -
