Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

48350 / 76732

←次へ　｜　前へ→


	【33318】Re:数字の比較について

Hirofumi - 06/1/8(日) 22:53 -


	引用なし

	パスワード

Sheet1が以下の様

　　　A　　　　B
１　１００　　鉛筆
２　２００　　メモ
３　２５０　　ノート

Sheet2が以下の様

　　A　　　　　B　　
１　５０　　　みかん
２　１００　　りんご
３　１５０　　なし
４　２５０　　メロン

基本的に　だるまさん　と同じロジックのコードです

Option Explicit

Public Sub Extraction()

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

　　MsgBox strProm, vbInformation
　　
End Sub

0 hits

▼

【33308】数字の比較について 超初心者 06/1/8(日) 17:21