Excel VBA質問箱 IV

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

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


50044 / 76738 ←次へ | 前へ→

【31590】Re:データマッチングについて
回答  Hirofumi  - 05/11/25(金) 22:55 -

引用なし
パスワード
   Sheet1のA、Bに比較するデータが有り、結果をSheet2のA,Bに出します
尚、Sheet1には、列見出しが有る物とします

Option Explicit
Option Compare Text

Public Sub Extraction()

  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 rngExtract1 As Range
  Dim lngExtract1 As Long
  Dim rngExtract2 As Range
  Dim lngExtract2 As Long
  Dim strProm As String
  
  '抽出データを書きこむ位置を指定
  With Worksheets("Sheet2")
    Set rngExtract1 = .Cells(1, "A")
    Set rngExtract2 = .Cells(1, "B")
  End With
  
  'Sheet1のA1を基準とします(Listの左上隅)
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  '基準に就いて
  With rngList1
    '行数を取得
    lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd1 <= 0 Then
      strProm = .Address(False, False) & "以下にデータが有りません"
      GoTo Wayout
    End If
    '品番列を配列に取得
    vntList1 = .Offset(1).Resize(lngEnd1).Value
  End With
  
  '"Sheet1"のB1を基準とする
  Set rngList2 = Worksheets("Sheet1").Cells(1, "B")
  '基準に就いて
  With rngList2
    '行数を取得
    lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd2 <= 0 Then
      strProm = .Address(False, False) & "以下にデータが有りません"
      GoTo Wayout
    End If
    '品目番号列を配列に取得
    vntList2 = .Offset(1).Resize(lngEnd2).Value
  End With
  
  'A列の書き込み行を初期値に(Offse値)
  lngExtract1 = 0
  'A列の比較位置
  lngRow1 = 1
  'B列の書き込み行を初期値に(Offse値)
  lngExtract2 = 0
  'B列の比較位置
  lngRow2 = 1
  'A列若しくは,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列固有行の場合
        '出力位置を更新
        lngExtract2 = lngExtract2 + 1
        'B列の値を配列に出力
        vntList2(lngExtract2, 1) = vntList2(lngRow2, 1)
        'B列の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntList2(lngRow2, 1) 'A列固有行の場合
        '出力位置を更新
        lngExtract1 = lngExtract1 + 1
        'A列のの値を配列に出力
        vntList1(lngExtract1, 1) = vntList1(lngRow1, 1)
        'A列の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
  
  Application.ScreenUpdating = False
  
  '残ったA列の固有値を配列に出力
  For i = lngRow1 To lngEnd1
    '出力位置を更新
    lngExtract1 = lngExtract1 + 1
    'A列のの値を配列に出力
    vntList1(lngExtract1, 1) = vntList1(i, 1)
  Next i
  'シートに配列を出力
  rngExtract1.Offset(1).Resize(lngExtract1).Value = vntList1
  
  '残ったB列の固有値を配列に出力
  For i = lngRow2 To lngEnd2
    '出力位置を更新
    lngExtract2 = lngExtract2 + 1
    'B列の値を配列に出力
    vntList2(lngExtract2, 1) = vntList2(i, 1)
  Next i
  'シートに配列を出力
  rngExtract2.Offset(1).Resize(lngExtract2).Value = vntList2
  
  Application.ScreenUpdating = True
  
  strProm = "処理が完了しました"
  
Wayout:

  Set rngList1 = Nothing
  Set rngList2 = Nothing
  Set rngExtract1 = Nothing
  Set rngExtract2 = Nothing
    
  MsgBox strProm, vbInformation
  
End Sub

0 hits

【31567】データマッチングについて マッチ 05/11/25(金) 17:00 質問
【31571】Re:データマッチングについて ichinose 05/11/25(金) 18:08 発言
【31575】Re:データマッチングについて だるま 05/11/25(金) 18:58 発言
【31586】Re:データマッチングについて Kein 05/11/25(金) 21:07 回答
【31590】Re:データマッチングについて Hirofumi 05/11/25(金) 22:55 回答

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