Excel VBA質問箱 IV

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

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


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

【6587】2つのシートで比較 ヒダリ 03/7/11(金) 22:57 質問
【6588】Re:2つのシートで比較 Hirofumi 03/7/12(土) 8:46 回答
【6589】Re:2つのシートで比較 ichinose 03/7/12(土) 9:10 回答
【6600】Re:2つのシートで比較 ヒダリ 03/7/14(月) 14:02 お礼

【6587】2つのシートで比較
質問  ヒダリ  - 03/7/11(金) 22:57 -

引用なし
パスワード
   はじめまして。
過去ログになかったので質問させて頂きます。
以下のようなマクロを作っているのですが、どうしてもうまくいきません。
よい方法がありましたらご教授お願いします。

シート1
A    B 
5241 125500011
3528 135522443
2258 125500012
:    :

シート2
A    B
4968
2258 
6698


↑の2つのシートで両方のA列を比較し、シート2のA列にシート1のA列の
コードがあれば、シート2のB列にシート1の対応するB列のコードを
貼っていくという作業をシート2のデータがなくなるまで行いたいのです。
同じコードはシート上のどこかのセルにあればよく(同じ行である必要はない)、
シート2には、同じコードが複数ある場合があります。

宜しくお願いします。

【6588】Re:2つのシートで比較
回答  Hirofumi E-MAIL  - 03/7/12(土) 8:46 -

引用なし
パスワード
   リソース的には不利ですが、Findで探すより速いかな?
上手くいかなかったらゴメン

Public Sub Test1()

  Dim i As Long
  Dim j As Long
  Dim vntRefe As Variant
  Dim lngRefCount As Long
  Dim lngRefPos As Long
  Dim vntData As Variant
  Dim lngDataCount As Long
  Dim wksData As Worksheet
  Dim lngDataTop As Long
  
  '参照するデータの取得
  With Worksheets("Sheet1")
    '2行目から
    vntRefe = Range(.Cells(2, 1), _
          .Cells(65536, 2).End(xlUp)).Value
  End With
  'データ数の取得
  lngRefCount = UBound(vntRefe, 1)
  'データをソート
  ShellSort vntRefe
  
  '探索するデータのシート
  Set wksData = Worksheets("Sheet2")
  'データの先頭を2行目とする
  lngDataTop = 2
  With wksData
    '探索するデータを取得
    vntData = Range(.Cells(lngDataTop, 1), _
          .Cells(65536, 1).End(xlUp)).Value
  End With
  '探索データ数の取得
  lngDataCount = UBound(vntData, 1)
  '配列を拡張
  ReDim Preserve vntData(1 To lngDataCount, 1 To 2)
  '探索データに行位置を代入
  For i = 1 To lngDataCount
    vntData(i, 2) = i + lngDataTop - 1
  Next i
  '探索データをソート
  ShellSort vntData
  
  'データの探索と書き込み
  With wksData
    '参照位置の初期値
    lngRefPos = 1
    '探索データを1つづつ取り出す
    For i = 1 To lngDataCount
      '探索先のデータが無くなるまで繰り返し
      Do Until lngRefPos > lngRefCount
        'もし、探索値が参照値より等しいか大きいなら
        If vntData(i, 1) <= vntRefe(lngRefPos, 1) Then
          'もし、探索値が参照値より等しいなら
          If vntData(i, 1) = vntRefe(lngRefPos, 1) Then
            'セルに代入
            .Cells(vntData(i, 2), 2).Value _
                      = vntRefe(lngRefPos, 2)
          End If
          'Doを抜ける
          Exit Do
        End If
        '参照位置を更新
        lngRefPos = lngRefPos + 1
      Loop
    Next i
  End With
      
  Set wksData = Nothing
  
End Sub

Private Sub ShellSort(vntList As Variant)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim vntTmp(1) As Variant
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(vntList, 1)
  lngEnd = UBound(vntList, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap <= 0
    For i = lngGap + lngTop To lngEnd
      vntTmp(0) = vntList(i, 1)
      vntTmp(1) = vntList(i, 2)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(j - lngGap, 1) <= vntTmp(0) Then
          Exit For
        End If
        vntList(j, 1) = vntList(j - lngGap, 1)
        vntList(j, 2) = vntList(j - lngGap, 2)
      Next j
      vntList(j, 1) = vntTmp(0)
      vntList(j, 2) = vntTmp(1)
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

【6589】Re:2つのシートで比較
回答  ichinose  - 03/7/12(土) 9:10 -

引用なし
パスワード
   ▼ヒダリ さん:
おはようございます。
>はじめまして。
>過去ログになかったので質問させて頂きます。
>以下のようなマクロを作っているのですが、どうしてもうまくいきません。
>よい方法がありましたらご教授お願いします。
>
>シート1
> A    B 
>5241 125500011
>3528 135522443
>2258 125500012
> :    :
>
>シート2
> A    B
>4968
>2258 
>6698
> :
>
>↑の2つのシートで両方のA列を比較し、シート2のA列にシート1のA列の
>コードがあれば、シート2のB列にシート1の対応するB列のコードを
>貼っていくという作業をシート2のデータがなくなるまで行いたいのです。
>同じコードはシート上のどこかのセルにあればよく(同じ行である必要はない)、
>シート2には、同じコードが複数ある場合があります。
>
>宜しくお願いします。
シート1、シート2共に1行目からデータが入っていた場合の例です。
'================================================
Sub main()
  Dim vlookup_func As String
  Dim rng2 As Range
  With Worksheets("シート1")
   vlookup_func = "vlookup(rc[-1],シート1!" & _
           .Range(.Cells(1, 1), _
           .Cells(.Rows.Count, 1).End(xlUp)) _
           .Resize(, 2) _
           .Address(, , xlR1C1) & _
           ",2,false)"
   End With
  With Worksheets("シート2")
   Set rng2 = .Range(.Cells(1, 1), _
         .Cells(.Rows.Count, 1) _
         .End(xlUp)) _
         .Offset(0, 1)
   End With
  With rng2
    .Formula = "=if(iserror(" & _
         vlookup_func & "),""""," _
         & vlookup_func & ")"
    .Value = .Value
    End With
End Sub

シート名の最後の数字が半角か全角かわかりませんが、
ヒダリさんのシート名に合わせてください。

【6600】Re:2つのシートで比較
お礼  ヒダリ  - 03/7/14(月) 14:02 -

引用なし
パスワード
   hirofumiさん、ichinoseさん、どうもありがとうございます。
私ももっとvlookup等勉強します。

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