Excel VBA質問箱 IV

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

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


11777 / 13645 ツリー ←次へ | 前へ→

【14151】2つの条件で1つの結果を表示したい バカボン 04/5/22(土) 6:52 質問[未読]
【14210】Re:2つの条件で1つの結果を表示したい Hirofumi 04/5/23(日) 18:57 回答[未読]
【14226】Re:2つの条件で1つの結果を表示したい バカボン 04/5/24(月) 9:58 お礼[未読]

【14151】2つの条件で1つの結果を表示したい
質問  バカボン E-MAIL  - 04/5/22(土) 6:52 -

引用なし
パスワード
   2つシートのがあって、2つの条件を満たした値『文字列』を表示するようにしたい。 
sheet1をマスター sheet2をトランザクションだと考えて頂ければ分かりやすいかと思います。 
<sheet1> 
 A    B     C   D    E  F   G  H   I   J 
コード1 商品1 商品2 商品3 ***** ***** ***** ***** ***** ***** 
<sheet2> 
 A    B     C   
コード1 広告1 タイトル1 
コード5 広告3 タイトル3  
コード2 広告4 タイトル4  
コード1 広告6 タイトル5  
------------------------------------------------------------------- 
このような状況で、sheet1のE1には、sheet2のコードが一致しなおかつ、広告1であれば 
sheet1のE1にタイトル1を表示。sheet1のJ1は6番目なので、コチラもコードが一致し 
広告6であれば、タイトル6を表示。 
※広告の部分は、アルファベットと数字が混ざる文字列です

というようにしたいのですが、どのように構文を指定すればいいのでしょうか? 
どなたかご教授願います。

【14210】Re:2つの条件で1つの結果を表示したい
回答  Hirofumi E-MAIL  - 04/5/23(日) 18:57 -

引用なし
パスワード
   レスが付かないみたいですね?

どうやって広告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

【14226】Re:2つの条件で1つの結果を表示したい
お礼  バカボン E-MAIL  - 04/5/24(月) 9:58 -

引用なし
パスワード
   Hirofumiさんありがとうございます。
おかげさまで無事解決できそうです。
レイアウトに関して説明不足ですみません。
Hirofumi さんの書かれたとおりのレイアウトで考えてました(^^;;

初心者で何も分からないですが、今後ともよろしくお願いします。

11777 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free