| |
Dictionaryオブジェクトが使える環境ならこんなコードで善いかな？
以下を標準モジュールに記述してください
Option Explicit
Public Sub Classification()
'分類名の間隔のピッチ
Const lngRowPitch As Long = 15
Dim i As Long
Dim lngRow As Long
Dim vntSheets As Variant
Dim vntWritePos As Variant
Dim vntClass() As Variant
Dim wksResult As Worksheet
Dim dicIndex As Object
'画面更新を停止
Application.ScreenUpdating = False
'分類シートの参照を設定
Set wksResult = Worksheets("分類シート")
'分類シートの分類項目の初期位置を配列に取得
With wksResult.Cells(8, "A")
'配列の添え字の初期値
i = 0
'分類の初期位置の初期値
lngRow = i * lngRowPitch + 1
'分類項目が無くなるまで繰り返し
Do Until .Offset(lngRow).Value = ""
'初期位置の配列を確保
ReDim Preserve vntClass(1, i)
'分類名を代入
vntClass(0, i) = .Offset(lngRow).Value
'初期位置を代入
vntClass(1, i) = lngRow + .Row
'添え字のカウンタを更新
i = i + 1
'初期位置を計算
lngRow = i * lngRowPitch + 1
Loop
End With
'データの有るシート名を配列に設定
vntSheets = Array("型式1シート", "型式2シート")
'分類シートに対するデータの出力位置を設定
vntWritePos = Array("C", "G")
'Dictionaryオブジェクトのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'データの有るシート数繰り返し
For i = 0 To UBound(vntSheets)
'データの出力
ListingData Worksheets(vntSheets(i)), _
vntWritePos(i), vntClass, _
lngRowPitch, dicIndex, wksResult
Next i
'Dictionaryオブジェクトのインスタンスを破棄
Set dicIndex = Nothing
'分類シートの参照を破棄
Set wksResult = Nothing
'画面更新を再開
Application.ScreenUpdating = True
Beep
MsgBox "処理が終了しました"
End Sub
Private Sub ListingData(wksData As Worksheet, _
vntCol As Variant, _
vntClass As Variant, _
lngPitch As Long, _
dicIndex As Object, _
wksResult As Worksheet)
Dim i As Long
Dim lngEnd As Long
Dim vntComp As Variant
Dim lngRow As Long
'Dictionaryに初期値を設定
With dicIndex
For i = 0 To UBound(vntClass, 2)
.Item(vntClass(0, i)) = vntClass(1, i)
Next i
End With
'データの出力
With wksData
'データの最終行を取得
lngEnd = .Cells(65536, "A").End(xlUp).Row
'列見だしの下から最終行まで繰り返し
For i = 2 To lngEnd
'比較値を変数に取得
vntComp = .Cells(i, "D").Value
'もしdicIndexに比較値が有なら
If dicIndex.Exists(vntComp) Then
'出力位置を取得
lngRow = dicIndex.Item(vntComp)
'出力位置を更新
dicIndex.Item(vntComp) = lngRow + 1
'もしdicIndexに比較値が無いなら（分類項目が無い場合）
Else
'出力位置を最終分類項目のピッチ分下に設定
lngRow = vntClass(1, UBound(vntClass, 2)) + lngPitch
'分類項目を追加
wksResult.Cells(lngRow, "A").Value = vntComp
'初期位置の配列を拡張し、分類名と書き込み位置を追加
ReDim Preserve vntClass(1, UBound(vntClass, 2) + 1)
vntClass(0, UBound(vntClass, 2)) = vntComp
vntClass(1, UBound(vntClass, 2)) = lngRow
'dicIndexに分類名と書き込み位置を追加
dicIndex.Add vntComp, lngRow
End If
'分類の位置にデータを出力
.Cells(i, "A").Resize(, 3).Copy _
Destination:=wksResult.Cells(lngRow, vntCol)
Next i
End With
End Sub
|
|
Hirofumi
- 04/5/1(土) 9:34 -
