| |
OSとExcelのバージョンは、何ですか？
Dictionaryオブジェクトは、WHS（Windows Script Host）に含まれる物で
Win98以降なら使えると思いましたが？
ただ、Dictionaryオブジェクトが無くても、少し遅く成りますが
作る事は出来ます
其の場合は以下の様に成ります
以下を標準モジュールに記述して下さい
ただし、Excelは最低限97を使用してください
Excel95は、多分駄目でしょう
Option Explicit
Public Sub Classification2()
'分類名の間隔のピッチ
Const lngRowPitch As Long = 15
Dim i As Long
Dim lngRow As Long
Dim vntSheets As Variant
Dim vntClass As Variant
Dim wksResult As Worksheet
'画面更新を停止
Application.ScreenUpdating = False
'分類シートの参照を設定
Set wksResult = Worksheets("分類シート")
'分類シートの分類項目の初期位置を配列に取得
With wksResult.Cells(8, "A")
'初期位置の配列を初期化
ReDim vntClass(1, 0)
vntClass(1, 0) = .Row + 1 - lngRowPitch
'配列の添え字の初期値
i = 1
'分類の初期位置の初期値
lngRow = (i - 1) * 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 - 1) * lngRowPitch + 1
Loop
End With
'データの有るシート名を配列に設定
vntSheets = Array("型式1シート", "型式2シート")
'データの有るシート数繰り返し
For i = 0 To UBound(vntSheets)
'データの出力
ListingData Worksheets(vntSheets(i)), _
Chr(&H43 + i * 4), vntClass, _
lngRowPitch, wksResult
Next i
'分類シートの参照を破棄
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, _
wksResult As Worksheet)
Dim i As Long
Dim lngEnd As Long
Dim vntComp As Variant
Dim lngRow As Long
Dim vntScope As Variant
Dim lngPos As Long
'出力位置を初期位置とする
vntScope = vntClass
'データの出力
With wksData
'データの最終行を取得
lngEnd = .Cells(65536, "A").End(xlUp).Row
'列見だしの下から最終行まで繰り返し
For i = 2 To lngEnd
'比較値を変数に取得
vntComp = .Cells(i, "D").Value
'出力位置の添え字を取得
lngPos = RowSearch(vntComp, vntScope)
'もし、比較値が有るなら
If lngPos <> -1 Then
'出力位置を取得
lngRow = vntScope(1, lngPos)
'出力位置を更新
vntScope(1, lngPos) = lngRow + 1
'もし、比較値が無いなら（分類項目が無い場合）
Else
'出力位置を最終分類項目のピッチ分下に設定
lngRow = vntScope(1, UBound(vntScope, 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
ReDim Preserve vntScope(1, UBound(vntScope, 2) + 1)
vntScope(0, UBound(vntScope, 2)) = vntComp
vntScope(1, UBound(vntScope, 2)) = lngRow + 1
End If
'分類の位置にデータを出力
.Cells(i, "A").Resize(, 3).Copy _
Destination:=wksResult.Cells(lngRow, vntCol)
Next i
End With
End Sub
Private Function RowSearch(vntKey As Variant, _
vntScope As Variant) As Long
Dim i As Long
RowSearch = -1
If VarType(vntScope) = vbArray + vbVariant Then
For i = 1 To UBound(vntScope, 2)
If vntKey = vntScope(0, i) Then
RowSearch = i
Exit For
End If
Next i
End If
End Function
|
|
Hirofumi
- 04/5/1(土) 17:28 -
