Excel VBA質問箱 IV

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

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


62172 / 76732 ←次へ | 前へ→

【19168】Re:検索について
回答  ちゃっぴ  - 04/10/24(日) 13:37 -

引用なし
パスワード
   ▼seya さん:
>Sheet1のB1セルの数値が、Sheet2のB列の数値で一致するセルがあった場合、Sheet1のB1を含むその行を、Sheet2の一致した行に上書きするにはどうしたらいいのでしょうか。 よろしくお願いします。

こういったMatchingの方法はいろいろありますが・・・
とりあえず、基本的なMatchingアルゴリズムを書いておきます。

双方のデータをSortしてから、総当りでMatchingしているものですが、
配列を用いているため、高速なはずです。

他に、高速なものとしてはDictionaryを用いたものとかあります。
興味があったらチャレンジしてみては?

Const MAX_LONG = &H7FFFFFFF

Sub test1()
  Dim rngList1 As Range
  Dim rngList2 As Range
  Dim rngTemp1 As Range
  Dim rngTemp2 As Range
  Dim lngRowC1 As Long
  Dim lngRowC2 As Long
  Dim vntList1 As Variant
  Dim vntList2 As Variant
  Dim lngUCol1 As Long
  Dim i As Long, j As Long, k As Long
  
  'Sheet1
  Set rngList1 = Worksheets("Sheet1").Cells(1).CurrentRegion
  With rngList1
    'B列で昇順Sort
    .Sort Key1:=.Item(2), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, _
      SortMethod:=xlStroke, DataOption1:=xlSortNormal
    
    lngRowC1 = .Rows.Count
    
    'Matching漏れをなくすため、B列の最終行にLong型の最大値を付与
    Set rngTemp1 = .Item(2).Offset(lngRowC1)
    rngTemp1.Value = MAX_LONG
    
    '配列に代入
    vntList1 = .Resize(lngRowC1 + 1).Value
  End With
  
  
  lngUCol1 = UBound(vntList1, 2)
  
  'Sheet2
  Set rngList2 = Worksheets("Sheet2").Cells(1).CurrentRegion
  With rngList2
    'B列で昇順Sort
    .Sort Key1:=.Item(2), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, _
      SortMethod:=xlStroke, DataOption1:=xlSortNormal
    
    lngRowC2 = .Rows.Count
    
    'Matching漏れをなくすため、B列の最終行にLong型の最大値を付与
    Set rngTemp2 = .Item(2).Offset(lngRowC2)
    rngTemp2.Value = MAX_LONG
      
    Set rngList2 = .Resize(lngRowC2 + 1, lngUCol1)
    '配列に代入
    vntList2 = rngList2.Value
  End With

  
  i = 1
  j = 1
  
  'Matching
  Do
    Select Case vntList1(i, 2)
      Case Is < vntList2(j, 2)
        i = i + 1
      Case Is = vntList2(j, 2)
        '値のコピー
        For k = 1 To lngUCol1
          vntList2(j, k) = vntList1(i, k)
        Next k
        j = j + 1
      Case Is > vntList2(j, 2)
        j = j + 1
    End Select
  Loop Until i > lngRowC1 + 1 Or j > lngRowC2 + 1
  
  '結果の出力
  rngList2.Value = vntList2
  
  'Temp数字のクリア
  rngTemp1.ClearContents
  rngTemp2.ClearContents
End Sub

2 hits

【19164】検索について seya 04/10/24(日) 11:15 質問
【19165】Re:検索について かみちゃん 04/10/24(日) 12:00 回答
【19168】Re:検索について ちゃっぴ 04/10/24(日) 13:37 回答
【19172】Re:検索について seya 04/10/24(日) 15:38 質問
【19173】Re:検索について かみちゃん 04/10/24(日) 15:48 発言
【19174】Re:検索について seya 04/10/24(日) 17:12 質問
【19175】Re:検索について かみちゃん 04/10/24(日) 17:21 回答
【19177】Re:検索について ちゃっぴ 04/10/24(日) 17:58 回答
【19178】Re:検索について seya 04/10/24(日) 18:10 お礼

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