Excel VBA質問箱 IV

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

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


9742 / 13644 ツリー ←次へ | 前へ→

【25644】3つのコードと合致するデータに新しいコードを振る方法 Lee 05/6/9(木) 11:19 質問[未読]
【25658】Re:3つのコードと合致するデータに新しいコ... Hirofumi 05/6/9(木) 21:05 回答[未読]
【25668】Re:3つのコードと合致するデータに新しいコ... Lee 05/6/10(金) 9:32 質問[未読]
【25688】Re:3つのコードと合致するデータに新しいコ... Hirofumi 05/6/10(金) 21:36 回答[未読]
【25689】Re:3つのコードと合致するデータに新しいコ... Lee 05/6/10(金) 22:01 質問[未読]
【25690】Re:3つのコードと合致するデータに新しいコ... Lee 05/6/10(金) 22:07 質問[未読]
【25692】Re:3つのコードと合致するデータに新しいコ... Hirofumi 05/6/10(金) 22:32 回答[未読]
【25693】Re:3つのコードと合致するデータに新しいコ... Lee 05/6/10(金) 22:46 質問[未読]
【25694】Re:3つのコードと合致するデータに新しいコ... Hirofumi 05/6/10(金) 23:26 回答[未読]
【25695】Re:3つのコードと合致するデータに新しいコ... Hirofumi 05/6/11(土) 0:13 回答[未読]
【25696】Re:3つのコードと合致するデータに新しいコ... Lee 05/6/11(土) 0:53 お礼[未読]
【25698】Re:3つのコードと合致するデータに新しいコ... Hirofumi 05/6/11(土) 1:03 回答[未読]
【25699】Re:3つのコードと合致するデータに新しいコ... Lee 05/6/11(土) 1:15 お礼[未読]
【25697】Re:3つのコードと合致するデータに新しいコ... Hirofumi 05/6/11(土) 0:55 回答[未読]

【25644】3つのコードと合致するデータに新しいコー...
質問  Lee  - 05/6/9(木) 11:19 -

引用なし
パスワード
   エクセルデータで3つのコードを付けたデータ(Sheet1)

Aコード00001・Bコード001・Cコード010  
Aコード00001・Bコード002・Cコード010  
Aコード00002・Bコード001・Cコード010  
     ・     ・     ・
     ・     ・     ・

に別のコードを付けたシートがあります。(Sheet2)

Aコード00001・Bコード001・Cコード010  は Dコード001
Aコード00001・Bコード002・Cコード010  は Dコード001
Aコード00002・Bコード001・Cコード010  は Dコード002

2つのシートを紐付けて元のデータに新しいコードを振りたいのですが
どうしたらいいでしょうか?

【25658】Re:3つのコードと合致するデータに新しい...
回答  Hirofumi  - 05/6/9(木) 21:05 -

引用なし
パスワード
   どのシートから探して、どのシートのどの列に書き込むのか解らないので?
Sheet1、Sheet2が以下の様で、Sheet1のAコード、Bコード、Cコードを
Sheet2因り探索して、Sheet1のD列に書きこむとしています

Sheet1
  A     B     C
1 Aコード  Bコード  Cコード
2 00001   001    010
3 00001   002    010
4 00002   001    010
5 ・     ・     ・

Sheet2
  A     B     C     D
1 Aコード  Bコード  Cコード  Dコード
2 00001   001    010    001
3 00001   002    010    001
4 00002   001    010    002
5 ・     ・     ・    ・

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim vntData As Variant
  Dim lngRows As Long
  Dim rngResult As Range
  Dim strResult() As String
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim strProm As String
  
  'Sheet2のList先頭セルを指定(列見出しの左上隅)
  With Worksheets("Sheet2").Cells(1, "A")
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows, 4).Value
  End With
  
  'Dictionaryオブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  'Indexを作成
  With dicIndex
    'データ全てに繰り返し
    For i = 1 To lngRows
      'Aコード、Bコード、CコードをKeyとする
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3)
      'もしKeyが重複する場合
      If .Exists(vntKey) Then
        strProm = "Keyが重複しています"
        GoTo Wayout
      Else
        'KeyとDコードをIndexに登録
        .Add vntKey, vntData(i, 4)
      End If
    Next i
  End With
  
  'Sheet1のList先頭セルを指定(列見出しの左上隅)
  Set rngResult = Worksheets("Sheet1").Cells(1, "A")
  With rngResult
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    vntData = .Offset(1).Resize(lngRows, 3).Value
  End With
  
  '結果用配列を確保
  ReDim strResult(1 To lngRows, 1 To 1)
  'Sheet1のKeyをIndexから探索
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3)
      'Keyが有ったら結果用配列に代入
      If .Exists(vntKey) Then
        strResult(i, 1) = .Item(vntKey)
      End If
    Next i
  End With
  
  '結果を出力
  With rngResult
    .Offset(1, 3).Resize(lngRows).Value = strResult
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Set dicIndex = Nothing
  Set rngResult = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

【25668】Re:3つのコードと合致するデータに新しい...
質問  Lee  - 05/6/10(金) 9:32 -

引用なし
パスワード
   ▼Hirofumi さん:
>どのシートから探して、どのシートのどの列に書き込むのか解らないので?
>Sheet1、Sheet2が以下の様で、Sheet1のAコード、Bコード、Cコードを
>Sheet2因り探索して、Sheet1のD列に書きこむとしています
>
>Sheet1
>  A     B     C
> 1 Aコード  Bコード  Cコード
> 2 00001   001    010
> 3 00001   002    010
> 4 00002   001    010
> 5 ・     ・     ・
>
>Sheet2
>  A     B     C     D
> 1 Aコード  Bコード  Cコード  Dコード
> 2 00001   001    010    001
> 3 00001   002    010    001
> 4 00002   001    010    002
> 5 ・     ・     ・    ・
>
>Option Explicit
>
>Public Sub Sample()
>
>  Dim i As Long
>  Dim vntData As Variant
>  Dim lngRows As Long
>  Dim rngResult As Range
>  Dim strResult() As String
>  Dim dicIndex As Object
>  Dim vntKey As Variant
>  Dim strProm As String
>  
>  'Sheet2のList先頭セルを指定(列見出しの左上隅)
>  With Worksheets("Sheet2").Cells(1, "A")
>    'データ行数を取得
>    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
>    If lngRows <= 0 Then
>      strProm = "データが有りません"
>      GoTo Wayout
>    End If
>    'データを配列に取得
>    vntData = .Offset(1).Resize(lngRows, 4).Value
>  End With
>  
>  'Dictionaryオブジェクトのインスタンスを取得
>  Set dicIndex = CreateObject("Scripting.Dictionary")
>  'Indexを作成
>  With dicIndex
>    'データ全てに繰り返し
>    For i = 1 To lngRows
>      'Aコード、Bコード、CコードをKeyとする
>      vntKey = vntData(i, 1) & vbTab _
>            & vntData(i, 2) _
>              & vbTab & vntData(i, 3)
>      'もしKeyが重複する場合
>      If .Exists(vntKey) Then
>        strProm = "Keyが重複しています"
>        GoTo Wayout
>      Else
>        'KeyとDコードをIndexに登録
>        .Add vntKey, vntData(i, 4)
>      End If
>    Next i
>  End With
>  
>  'Sheet1のList先頭セルを指定(列見出しの左上隅)
>  Set rngResult = Worksheets("Sheet1").Cells(1, "A")
>  With rngResult
>    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
>    If lngRows <= 0 Then
>      strProm = "データが有りません"
>      GoTo Wayout
>    End If
>    vntData = .Offset(1).Resize(lngRows, 3).Value
>  End With
>  
>  '結果用配列を確保
>  ReDim strResult(1 To lngRows, 1 To 1)
>  'Sheet1のKeyをIndexから探索
>  With dicIndex
>    For i = 1 To lngRows
>      vntKey = vntData(i, 1) & vbTab _
>            & vntData(i, 2) _
>              & vbTab & vntData(i, 3)
>      'Keyが有ったら結果用配列に代入
>      If .Exists(vntKey) Then
>        strResult(i, 1) = .Item(vntKey)
>      End If
>    Next i
>  End With
>  
>  '結果を出力
>  With rngResult
>    .Offset(1, 3).Resize(lngRows).Value = strResult
>  End With
>  
>  strProm = "処理が完了しました"
>  
>Wayout:
>  
>  Set dicIndex = Nothing
>  Set rngResult = Nothing
>  
>  Beep
>  MsgBox strProm
>  
>End Sub

おはようございます。
早速、シート名とコード名を差し替えて試してみたのですが
「Keyが重複しています。」
と表示され、Dコードは振られませんでした。。。
どうしたらいいのでしょうか?
元データにはA・B・Cコードが同じのもが複数あるからでしょうか?

【25688】Re:3つのコードと合致するデータに新しい...
回答  Hirofumi  - 05/6/10(金) 21:36 -

引用なし
パスワード
   >おはようございます。
>早速、シート名とコード名を差し替えて試してみたのですが
>「Keyが重複しています。」
>と表示され、Dコードは振られませんでした。。。
>どうしたらいいのでしょうか?
>元データにはA・B・Cコードが同じのもが複数あるからでしょうか?

Sheet2に、Aコード且つ、Bコード且つ、Cコードの物が複数ある場合
このメッセージを出して終了する様に就くって有ります
Sheet2に、Aコード且つ、Bコード且つ、Cコードの物の、
Dコードが違っているなら、コードの振り直しは出来ないのでは?(一意になら無い為)
Dコードが同じなら、以下の様に成ります

Option Explicit

Public Sub Sample2()

  Dim i As Long
  Dim vntData As Variant
  Dim lngRows As Long
  Dim rngResult As Range
  Dim strResult() As String
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim strProm As String
  
  'Sheet2のList先頭セルを指定(列見出しの左上隅)
  With Worksheets("Sheet2").Cells(1, "A")
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows, 4).Value
  End With
  
  'Dictionaryオブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  'Indexを作成
  With dicIndex
    'データ全てに繰り返し
    For i = 1 To lngRows
      'Aコード、Bコード、CコードをKeyとする
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3)
      'もしKeyが重複する場合
      If .Exists(vntKey) Then
        'Dコードが違うなら
        If .Item(vntKey) <> vntData(i, 4) Then
          strProm = "Keyが重複しています"
          GoTo Wayout
        End If
      Else
        'KeyとDコードをIndexに登録
        .Add vntKey, vntData(i, 4)
      End If
    Next i
  End With
  
  'Sheet1のList先頭セルを指定(列見出しの左上隅)
  Set rngResult = Worksheets("Sheet1").Cells(1, "A")
  With rngResult
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    vntData = .Offset(1).Resize(lngRows, 3).Value
  End With
  
  '結果用配列を確保
  ReDim strResult(1 To lngRows, 1 To 1)
  'Sheet1のKeyをIndexから探索
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3)
      'Keyが有ったら結果用配列に代入
      If .Exists(vntKey) Then
        strResult(i, 1) = .Item(vntKey)
      End If
    Next i
  End With
  
  '結果を出力
  With rngResult
    .Offset(1, 3).Resize(lngRows).Value = strResult
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Set dicIndex = Nothing
  Set rngResult = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

【25689】Re:3つのコードと合致するデータに新しい...
質問  Lee  - 05/6/10(金) 22:01 -

引用なし
パスワード
   ▼Hirofumi さん:
>>おはようございます。
>>早速、シート名とコード名を差し替えて試してみたのですが
>>「Keyが重複しています。」
>>と表示され、Dコードは振られませんでした。。。
>>どうしたらいいのでしょうか?
>>元データにはA・B・Cコードが同じのもが複数あるからでしょうか?
>
>
>

こんばんは。

私の説明不足だったようです。。。

作業としては 

Sheet1に、Aコード、Bコード、Cコード、Dコードがあります。

Sheet 2の、Aコード、Bコード、Cコード、が
Sheet 1の、Aコード且つ、Bコード且つ、Cコードと合致するものには
Sheet 1の、同じ行のDコードを付けるという流れなんです…

元データのSheet 2にはDコードは存在しません。

アドバイスいただいたモジュールとはまったく違う流れでしょうか?

【25690】Re:3つのコードと合致するデータに新しい...
質問  Lee  - 05/6/10(金) 22:07 -

引用なし
パスワード
   ▼Hirofumi さん:
追加です。。。

Sheet 2にはAコード、Bコード、Cコードが重複する物が複数存在します。
重複しても
Sheet 1のAコード且つ、Bコード且つ、Cコードと合致するものにはDコードを振ります。
Sheet 2には全てのデータにDコードが追記された形にしたいのです。
よろしくお願いいたします。

【25692】Re:3つのコードと合致するデータに新しい...
回答  Hirofumi  - 05/6/10(金) 22:32 -

引用なし
パスワード
   [25644]の質問
>エクセルデータで3つのコードを付けたデータ(Sheet1)
>
>Aコード00001・Bコード001・Cコード010  
>Aコード00001・Bコード002・Cコード010  
>Aコード00002・Bコード001・Cコード010  
>     ・     ・     ・
>     ・     ・     ・
>
>に別のコードを付けたシートがあります。(Sheet2)
>
>Aコード00001・Bコード001・Cコード010  は Dコード001
>Aコード00001・Bコード002・Cコード010  は Dコード001
>Aコード00002・Bコード001・Cコード010  は Dコード002
>
>2つのシートを紐付けて元のデータに新しいコードを振りたいのですが
>どうしたらいいでしょうか

[25689]の質問
>こんばんは。
>
>私の説明不足だったようです。。。
>
>作業としては 
>
>Sheet1に、Aコード、Bコード、Cコード、Dコードがあります。
>
>Sheet 2の、Aコード、Bコード、Cコード、が
>Sheet 1の、Aコード且つ、Bコード且つ、Cコードと合致するものには
>Sheet 1の、同じ行のDコードを付けるという流れなんです…
>
>元データのSheet 2にはDコードは存在しません。
>
>アドバイスいただいたモジュールとはまったく違う流れでしょうか?

[25690]の質問
>▼Hirofumi さん:
>追加です。。。
>
>Sheet 2にはAコード、Bコード、Cコードが重複する物が複数存在します。
>重複しても
>Sheet 1のAコード且つ、Bコード且つ、Cコードと合致するものにはDコードを振ります。
>Sheet 2には全てのデータにDコードが追記された形にしたいのです。
>よろしくお願いいたします。

[25644]と[25689]、[25690]の時で、Sheet1とSheet2が入れ替わっていますね?

[25658]の私の回答
>どのシートから探して、どのシートのどの列に書き込むのか解らないので?
>Sheet1、Sheet2が以下の様で、Sheet1のAコード、Bコード、Cコードを
>Sheet2因り探索して、Sheet1のD列に書きこむとしています
>
>Sheet1
>  A     B     C
>1 Aコード  Bコード  Cコード
>2 00001   001    010
>3 00001   002    010
>4 00002   001    010
>5 ・     ・     ・
>
>Sheet2
>  A     B     C     D
>1 Aコード  Bコード  Cコード  Dコード
>2 00001   001    010    001
>3 00001   002    010    001
>4 00002   001    010    002
>5 ・     ・     ・    ・

私のコードでは、最初の質問で、作っているので、Sheet2にDコード有り、
Sheet1のAコード且つ、Bコード且つ、CコードをSheet2から探して、
Sheet1にDコードを振るようにして有ります(Sheet1のKey重複はOK)

詰まり、最初のコードのSheet1とSheet2を入換えれば善いだけと思います
変更箇所は、

  Dim strProm As String
  
  'Sheet2のList先頭セルを指定(列見出しの左上隅)
'  With Worksheets("Sheet2").Cells(1, "A")
  With Worksheets("Sheet1").Cells(1, "A")

と、

  End With
  
  'Sheet1のList先頭セルを指定(列見出しの左上隅)
'  Set rngResult = Worksheets("Sheet1").Cells(1, "A")
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")

とすれば善いと思います

【25693】Re:3つのコードと合致するデータに新しい...
質問  Lee  - 05/6/10(金) 22:46 -

引用なし
パスワード
   ▼Hirofumi さん:
ホントに何度もすみません。。。

Sheet名を入れ替えたのですがやはり「Keyが重複します」とでてしまいます。
Sheet 1にDコードが重複してるのが原因でしょうか?

【25694】Re:3つのコードと合致するデータに新しい...
回答  Hirofumi  - 05/6/10(金) 23:26 -

引用なし
パスワード
   ▼Lee さん:
>▼Hirofumi さん:
>ホントに何度もすみません。。。
>
>Sheet名を入れ替えたのですがやはり「Keyが重複します」とでてしまいます。
>Sheet 1にDコードが重複してるのが原因でしょうか?

Sheet1にDコードが重複していても、Keyに成るコードが重複して居なければ
Key重複のメセージは出ない筈です

此れが出るのは、Sheet1に、A且つB且つCが重複している時に起こります
此れを確認する、コードを作って見ますので為して下さい

【25695】Re:3つのコードと合致するデータに新しい...
回答  Hirofumi  - 05/6/11(土) 0:13 -

引用なし
パスワード
   Sheet1(Dコードの有るList)の重複を検査します
重複が有る場合、Sheet3に結果を表示します
登録行"とは、最初に出てきた行位置で、
"重複行"とは、重複して出てきた行位置を示します

Option Explicit

Public Sub Examination()

  Dim i As Long
  Dim j As Long
  Dim vntData As Variant
  Dim lngRows As Long
  Dim lngRow As Long
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim strProm As String
  Dim lngOffset As Long
  
  '検査結果を出力するSheetを設定
  Set rngResult = Worksheets("Sheet3").Cells(1, "A")
  With rngResult.Resize(, 10)
    .Value = Array("登録行", "Aコード", "Bコード", "Cコード", "Dコード", _
            "重複行", "Aコード", "Bコード", "Cコード", "Dコード")
  End With
  '検査結果出力用配列を確保
  ReDim vntResult(1 To 1, 1 To 10)
  lngRow = 1
  
  'Sheet1(Dコードの有るList)のList先頭セルを指定(列見出しの左上隅)
  With Worksheets("Sheet1").Cells(1, "A")
    'Offset量
    lngOffset = .Row - 1
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows, 4).Value
  End With
  
  'Dictionaryオブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  'Indexを作成
  With dicIndex
    'データ全てに繰り返し
    For i = 1 To lngRows
      'Aコード、Bコード、CコードをKeyとする
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3)
      'もしKeyが重複する場合
      If .Exists(vntKey) Then
        vntResult(1, 1) = .Item(vntKey)
        vntResult(1, 6) = i + lngOffset
        For j = 1 To 4
          vntResult(1, j + 1) = vntData(vntResult(1, 1), j)
          vntResult(1, j + 6) = vntData(i, j)
        Next j
        With rngResult.Offset(lngRow).Resize(, 10)
          .NumberFormatLocal = "@"
          .Value = vntResult
        End With
        lngRow = lngRow + 1
      Else
        'KeyとDコードをIndexに登録
        .Add vntKey, i + lngOffset
      End If
    Next i
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Set dicIndex = Nothing
  Set rngResult = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

【25696】Re:3つのコードと合致するデータに新しい...
お礼  Lee  - 05/6/11(土) 0:53 -

引用なし
パスワード
   ▼Hirofumi さん:
Sheet名を入れ替えたりと何度かしていると、下記のコードで出来るようになりました。

Dim strProm As String
 
  'Sheet 2のList先頭セルを指定(列見出しの左上隅)←Dコードの入ったSheet’
  With Worksheets("Sheet 2").Cells(1, "A")

 
  'Sheet 1のList先頭セルを指定(列見出しの左上隅)←Dコードを入れたいSheet’
  Set rngResult = Worksheets("Sheet 1").Cells(1, "A")

初心者の私には何が原因だったのか解読できていないのですが…
こんなにも処理速度の早いコードを作っていただきありがとうございました。
重複確認プログラムも使わせていただきます。

わがままついでにもうひとつ質問なんですが、
3つのコードを2つに減らしたり4つに増やしたりした場合は、
下記の4.3.←☆の部分を変更すればいいのでしょうか?


'データを配列に取得
    vntData = .Offset(1).Resize(lngRows, 4.).Value
  End With
 
  'Dictionaryオブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  'Indexを作成
  With dicIndex
    'データ全てに繰り返し
    For i = 1 To lngRows
      '世話組織コード、組織コード、事業所コードをKeyとする
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3) ←☆
      'もしKeyが重複する場合
      If .Exists(vntKey) Then
        strProm = "Keyが重複しています"
        GoTo Wayout
      Else
        'Keyと配便コードをIndexに登録
        .Add vntKey, vntData(i, 4.)
      End If
    Next i
  End With
 
  '配便コード付のList先頭セルを指定(列見出しの左上隅)
  Set rngResult = Worksheets("配便コード付").Cells(1, "A")
  With rngResult
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    vntData = .Offset(1).Resize(lngRows, 3.).Value
  End With
 
  '結果用配列を確保
  ReDim strResult(1 To lngRows, 1 To 1)
  '世話組織・組織・事業所コード(配便コード順)0507のKeyをIndexから探索
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3) ←☆
      'Keyが有ったら結果用配列に代入
      If .Exists(vntKey) Then
        strResult(i, 1) = .Item(vntKey)
      End If
    Next i
  End With
 
  '結果を出力
  With rngResult
    .Offset(1, 3.).Resize(lngRows).Value = strResult
  End With
 
  strProm = "処理が完了しました"
 
Wayout:
 
  Set dicIndex = Nothing
  Set rngResult = Nothing
 
  Beep
  MsgBox strProm
 
End Sub

【25697】Re:3つのコードと合致するデータに新しい...
回答  Hirofumi  - 05/6/11(土) 0:55 -

引用なし
パスワード
   重複検査用コードにミスが有ったので、修正して下さい

  With Worksheets("Sheet1").Cells(2, "A")
    'Offset量
    lngOffset = .Row '★この行変更
    'データ行数を取得


      'もしKeyが重複する場合
      If .Exists(vntKey) Then
        vntResult(1, 1) = .Item(vntKey)
        vntResult(1, 6) = i + lngOffset
        For j = 1 To 4
          vntResult(1, j + 1) = vntData(vntResult(1, 1), j)
          vntResult(1, j + 6) = vntData(i, j)
        Next j
        vntResult(1, 1) = vntResult(1, 1) + lngOffset '☆この行追加
        With rngResult.Offset(lngRow).Resize(, 10)
          .NumberFormatLocal = "@"
          .Value = vntResult
        End With
        lngRow = lngRow + 1
      Else
        'KeyとDコードをIndexに登録
        .Add vntKey, i '★この行変更
      End If
    Next i

【25698】Re:3つのコードと合致するデータに新しい...
回答  Hirofumi  - 05/6/11(土) 1:03 -

引用なし
パスワード
   以下の部分も変更しないと、上手く有りません

    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows, 4).Value
  End With

    End If
    vntData = .Offset(1).Resize(lngRows, 3).Value
  End With

上は、List先頭から、4列を配列に格納していますし(A、B、C、Dコード)
下は、List先頭から、3列を配列に格納していますし(A、B、Cコード)

此れを変えないと、

      'Aコード、Bコード、CコードをKeyとする
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3)
      'もしKeyが重複する場合
      If .Exists(vntKey) Then
        strProm = "Keyが重複しています"
        GoTo Wayout
      Else
        'KeyとDコードをIndexに登録
        .Add vntKey, vntData(i, 4)
      End If



  'Sheet1のKeyをIndexから探索
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntData(i, 1) & vbTab _
            & vntData(i, 2) _
              & vbTab & vntData(i, 3)

が、使え無い(配列の値を使用している為)

【25699】Re:3つのコードと合致するデータに新しい...
お礼  Lee  - 05/6/11(土) 1:15 -

引用なし
パスワード
   ▼Hirofumi さん:
わかりました。

今日はもう遅いので、後日試してみますね。
細かいところまで親切に教えてくださってありがとうございました。
結果はきちんと報告しますね。


PS、重複プログの変更しました。(^_^)

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