Excel VBA質問箱 IV

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

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


74606 / 76732 ←次へ | 前へ→

【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
1 hits

【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 お礼

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