Excel VBA質問箱 IV

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

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


22876 / 76732 ←次へ | 前へ→

【59231】Re:セル内の文字列の比較VBAの改変
発言  Hirofumi  - 08/12/2(火) 21:37 -

引用なし
パスワード
   Dictionaryじゃ無いけど、こんなので出来ると思います
D列、B列が、共に昇順で整列済みとします
D列、B列共に列見出しが有る物とします

Option Explicit
Option Compare Text

Public Sub Extraction2()

  Dim i As Long
  Dim rngList1 As Range
  Dim lngEnd1 As Long
  Dim vntList1 As Variant
  Dim lngRow1 As Long
  Dim rngList2 As Range
  Dim lngEnd2 As Long
  Dim vntList2 As Variant
  Dim lngRow2 As Long
  Dim lngExtract As Long
  Dim vntExtract As Variant
  Dim strProm As String

  'D列のD1を基準とします(データの上のセル位置)
  Set rngList1 = Worksheets("Sheet1").Cells(1, "D")
  
  'B列のB1を基準とする
  Set rngList2 = Worksheets("Sheet1").Cells(1, "B")
  
  '基準に就いて
  With rngList1
    '行数を取得
    lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd1 < 0 Then
      strProm = "D列にデータが有りません"
      GoTo Wayout
    End If
    '品番列を配列に取得
    vntList1 = .Offset(1).Resize(lngEnd1).Value
    '結果用配列を確保
    ReDim vntExtract(1 To lngEnd1, 1 To 1)
  End With
  
  '基準に就いて
  With rngList2
    '行数を取得
    lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd2 < 0 Then
      strProm = "B列にデータが有りません"
      GoTo Wayout
    End If
    '品目番号列を配列に取得
    vntList2 = .Offset(1).Resize(lngEnd2).Value
  End With
  
  '書き込み行を初期値に
  lngExtract = 0
  '"D列"の比較位置
  lngRow1 = 1
  '"B列"の比較位置
  lngRow2 = 1
  'D列若しくは,B列が最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '比較結果に就いて
    Select Case vntList1(lngRow1, 1)
      Case Is = vntList2(lngRow2, 1) 'Matchiした場合
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntList2(lngRow2, 1) '"B列"固有値の場合
        '"B列"の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntList2(lngRow2, 1) '"D列"固有値の場合
        '出力位置を更新
        lngExtract = lngExtract + 1
        '結果配列に代入
        vntExtract(lngExtract, 1) = vntList1(lngRow1, 1)
        '"D列"の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
  
  '残った"D列"の固有値を出力
  For i = lngRow1 To lngEnd1
    '出力位置を更新
    lngExtract = lngExtract + 1
    '結果配列に代入
    vntExtract(lngExtract, 1) = vntList1(i, 1)
  Next i
  
  Application.ScreenUpdating = False

  '抽出データを書きこむ位置を指定
  With Worksheets("Sheet1").Cells(1, "F")
    .Offset(1).Resize(lngExtract).Value = vntExtract
  End With
    
  strProm = "処理が完了しました"
  
Wayout:
  
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
    
  MsgBox strProm, vbInformation
  
End Sub

1 hits

【59222】セル内の文字列の比較VBAの改変 PN 08/12/2(火) 18:20 質問
【59223】Re:セル内の文字列の比較VBAの改変 n 08/12/2(火) 18:31 発言
【59227】Re:セル内の文字列の比較VBAの改変 PN 08/12/2(火) 21:20 発言
【59229】Re:セル内の文字列の比較VBAの改変 n 08/12/2(火) 21:26 発言
【59232】申し訳ありません。 PN 08/12/2(火) 21:39 お礼
【59231】Re:セル内の文字列の比較VBAの改変 Hirofumi 08/12/2(火) 21:37 発言
【59233】ダブルで回答をありがとうございます。 PN 08/12/2(火) 21:42 お礼

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