| |
レスが付かないみたいですね？
どうやって広告1とか広告2とかの位置を探すのか？
Sheet1、Sheet2に列見出しが有るのか？、Sheet1は昇順に並んでいるのか等
イマイチ、説明が不足なので、勝手に考えて見ました
参考ぐらいには成るかな？
勝手に考えたレイアウトは以下の様に想定しています
Sheet1
A B C D E F G H I J
1 コード 商品1 商品2 商品3 広告1 広告2 広告3 広告4 広告5 広告6
2 1 A1 B1 C1
3 2 A2 B2 C2
4 3 A3 B3 C3
5 4 A4 B4 C4
6 5 A5 B5 C5
Sheet2
A B C
1 コード 広告 タイトル
2 1 広告1 Title1
3 5 広告3 Title3
4 2 広告4 Title4
5 1 広告6 Title5
Sheet1結果
A B C D E F G H I J
1 コード 商品1 商品2 商品3 広告1 広告2 広告3 広告4 広告5 広告6
2 1 A1 B1 C1 Title1 Title6
3 2 A2 B2 C2 Title4
4 3 A3 B3 C3
5 4 A4 B4 C4
6 5 A5 B5 C5 Title3
以下を標準モジュールに記述して下さい
Option Explicit
'シートの最終行位置を定数として宣言
Const clngSheetEnd As Long = 65536
Public Sub Classification()
'Sheet1のList先頭行位置を定数として宣言
Const clngRowTop As Long = 1
'Sheet1の広告列見出しの先頭列位置を定数宣言
Const clngColTop As Long = 5
'Sheet2のList先頭行位置を定数として宣言
Const clngDataTop As Long = 1
Dim i As Long
Dim lngDataEnd As Long
Dim dicCode As Object
Dim dicTitle As Object
Dim vntData As Variant
Dim wksData As Worksheet
Dim wksResult As Worksheet
Dim rngData As Range
Dim lngRow As Long
'画面更新を停止
' Application.ScreenUpdating = False
'コードのIndexをDictionaryとして取得
Set dicCode _
= CreateObject("Scripting.Dictionary")
'広告のIndexをDictionaryとして取得
Set dicTitle _
= CreateObject("Scripting.Dictionary")
'Sheet1の参照を格納
Set wksResult = Worksheets("Sheet1")
'Sheet1に就いて
With wksResult
'コード列を取得
Set rngData = Range(.Cells(clngRowTop + 1, "A"), _
.Cells(clngSheetEnd, "A").End(xlUp))
'コードのIndexを作成
If Not MakeIndex(dicCode, rngData, clngRowTop + 1) Then
GoTo ExitHandler
End If
'広告列見出しを取得
Set rngData = Range(.Cells(clngRowTop, clngColTop), _
.Cells(clngRowTop, 256).End(xlToLeft))
'広告のIndexを作成
If Not MakeIndex(dicTitle, rngData, clngColTop) Then
GoTo ExitHandler
End If
End With
'Sheet2の参照を格納
Set wksData = Worksheets("Sheet2")
'データの有るシートに就いて
With wksData
'データの最終行を取得
lngDataEnd = .Cells(clngSheetEnd, "A").End(xlUp).Row
End With
'データの有る先頭行〜最終行まで繰り返し
For i = clngDataTop + 1 To lngDataEnd
'配列にi行のA、B、C列を取得
vntData = wksData.Cells(i, "A").Resize(, 3).Value
With dicCode
'もし、コードのIndexにこのコードが有るなら
If .Exists(vntData(1, 1)) Then
'コードの行位置を取得
lngRow = .Item(vntData(1, 1))
'日付が無いなら
Else
'コードの行位置を-1に
lngRow = -1
End If
End With
If lngRow <> -1 Then
With dicTitle
'広告Indexにi行A列の値が有るなら
If .Exists(vntData(1, 2)) Then
'広告の列位置を取得し、
'コードの行位置との交点にタイトルを記入
wksResult.Cells(lngRow, _
.Item(vntData(1, 2))).Value _
= vntData(1, 3)
End If
End With
End If
Next i
ExitHandler:
'画面更新を再開
' Application.ScreenUpdating = True
'Dictionaryを破棄
Set dicCode = Nothing
Set dicTitle = Nothing
Set rngData = Nothing
Set wksData = Nothing
Set wksResult = Nothing
Beep
MsgBox "処理が完了しました"
End Sub
Private Function MakeIndex(dicIndex As Object, _
rngData As Range, _
lngTop As Long) As Boolean
' Indexを作成
Dim i As Long
'Indexに就いて
With dicIndex
'Listの先頭から終りまで繰り返し
For i = 1 To rngData.Count
'コードのIndexにこのコードが有る場合
If .Exists(rngData(i).Value) Then
Beep
MsgBox "同一のKeyが有ります"
Exit Function
'コードが無い場合
Else
'Indexにこのコードと行位置を追加
.Add rngData(i).Value, i + lngTop - 1
End If
Next i
End With
MakeIndex = True
End Function
|
|
Hirofumi
- 04/5/23(日) 18:57 -
