Excel VBA質問箱 IV

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

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


34314 / 76732 ←次へ | 前へ→

【47628】Re:二つのデータを見比べて、新リストを作成
回答  Hirofumi  - 07/3/16(金) 20:44 -

引用なし
パスワード
   なんか、質問の説明とイメージが合って無い様な?
A列とB列が一致した場合はどうなるの?
一応、一致した場合も出力しています
尚、A列、B列共に昇順整列済みとします

Option Explicit

Public Sub Extraction()

  'データの列数
  Const clngColumns As Long = 1
  
  Dim i As Long
  Dim lngEnd1 As Long
  Dim vntList1 As Variant
  Dim lngRow1 As Long
  Dim lngEnd2 As Long
  Dim vntList2 As Variant
  Dim lngRow2 As Long
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim strProm As String
  
  'A列ののA1を基準とします(Listの左上隅)
  With ActiveSheet.Cells(1, "A")
    '行数を取得
    lngEnd1 = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    If lngEnd1 <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'A列を配列に取得
    vntList1 = .Resize(lngEnd1 + 1, clngColumns).Value
  End With
  
  'B列のB1を基準とする
  With ActiveSheet.Cells(1, "B")
    '行数を取得
    lngEnd2 = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    If lngEnd1 <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'A、B列を配列に取得
    vntList2 = .Resize(lngEnd2 + 1, clngColumns).Value
  End With
  
  '結果出力用配列を確保
  ReDim vntResult(1 To lngEnd1 + lngEnd2, 1 To 1)
  
  '書き込み行を初期値に(Offse値)
  lngWrite = 0
  'Sheet1のA列の比較位置
  lngRow1 = 1
  'Sheet2のA列の比較位置
  lngRow2 = 1
  'Sheet1のA列若しくは,Sheet2のA列が最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '比較結果に就いて
    Select Case vntList1(lngRow1, 1)
      Case Is = vntList2(lngRow2, 1) 'Matchiした場合
        '出力位置を更新
        lngWrite = lngWrite + 1
        'A列のデータを配列に代入
        vntResult(lngWrite, 1) = vntList1(lngRow1, 1)
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntList2(lngRow2, 1) 'B列の固有行の場合
        '出力位置を更新
        lngWrite = lngWrite + 1
        'B列のデータを配列に代入
        vntResult(lngWrite, 1) = vntList2(lngRow2, 1)
        'B列の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntList2(lngRow2, 1) 'A列の固有行の場合
        '出力位置を更新
        lngWrite = lngWrite + 1
        'A列のデータを配列に代入
        vntResult(lngWrite, 1) = vntList1(lngRow1, 1)
        'A列の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
  
  '残ったA列の固有値を出力
  For i = lngRow1 To lngEnd1
    '出力位置を更新
    lngWrite = lngWrite + 1
    'データを配列に代入
    vntResult(lngWrite, 1) = vntList1(i, 1)
  Next i
  
  '残ったB列の固有値を出力
  For i = lngRow2 To lngEnd2
    '出力位置を更新
    lngWrite = lngWrite + 1
    'データを配列に代入
    vntResult(lngWrite, 1) = vntList2(i, 1)
  Next i
  
  Application.ScreenUpdating = False
  
  '抽出データを書きこむ位置を指定し結果配列を出力
  With ActiveSheet.Cells(1, "C").Resize(lngWrite)
    .NumberFormatLocal = "@"
    .Value = vntResult
  End With
  
  Application.ScreenUpdating = True
  
  strProm = "処理が完了しました"
  
Wayout:

  MsgBox strProm, vbInformation
  
End Sub

0 hits

【47625】二つのデータを見比べて、新リストを作成 Mia 07/3/16(金) 19:31 質問
【47627】Re:二つのデータを見比べて、新リストを作成 ウッシ 07/3/16(金) 20:15 発言
【47628】Re:二つのデータを見比べて、新リストを作成 Hirofumi 07/3/16(金) 20:44 回答
【47629】Re:二つのデータを見比べて、新リストを作成 ichinose 07/3/16(金) 21:07 発言
【47644】Re:二つのデータを見比べて、新リストを作成 Mia 07/3/17(土) 13:25 質問
【47645】Re:二つのデータを見比べて、新リストを作成 ウッシ 07/3/17(土) 13:41 発言
【47646】Re:二つのデータを見比べて、新リストを作成 Kein 07/3/17(土) 13:52 回答
【47647】Re:二つのデータを見比べて、新リストを作成 Hirofumi 07/3/17(土) 14:01 回答
【47696】Re:二つのデータを見比べて、新リストを作成 Mia 07/3/19(月) 16:45 質問
【47698】Re:二つのデータを見比べて、新リストを作成 Kein 07/3/19(月) 17:02 発言
【47700】Re:二つのデータを見比べて、新リストを作成 Mia 07/3/19(月) 17:59 質問
【47703】Re:二つのデータを見比べて、新リストを作成 ichinose 07/3/19(月) 18:50 発言
【47704】Re:二つのデータを見比べて、新リストを作... ichinose 07/3/19(月) 18:52 発言
【47657】Re:二つのデータを見比べて、新リストを作成 ichinose 07/3/17(土) 19:01 発言
【47686】Re:二つのデータを見比べて、新リストを作成 Mia 07/3/19(月) 7:33 お礼

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