Excel VBA質問箱 IV

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

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


44596 / 76735 ←次へ | 前へ→

【37154】Re:2つのシートを比較して一致する行を別シートに移動したい
回答  Hirofumi  - 06/4/23(日) 17:03 -

引用なし
パスワード
   出遅れました

もし、"vicky-com"、"com"の各々のシートの中でKeyが重複していた時
例えば、"vicky-com"に2つ同じKeyが有り、其のKeyが"com"にも1つ有った場合
"vicky-com"の最初のKeyと、"com"のKeyがMatchと見なされ転記されます
同じく、"vicky-com"、"com"に同じKeyが2つづつ有った場合、
両方がMatchと見なされ転記されます

尚、"vicky-com"、"com"各々は、H列、J列を作業列として使います

Option Explicit

Public Sub DataMatch()

'  データの転記

  '"vicky-com"のデータ列数(A列〜J列)
  Const clngColumns1 As Long = 10
  '"vicky-com"の比較Key列位置(G列)
  Const clngKeys1 As Long = 7
  '"com"のデータ列数(A列〜O列)
  Const clngColumns2 As Long = 15
  '"com"の比較Key列位置(I列)
  Const clngKeys2 As Long = 9
  
  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 rngMatch1 As Range
  Dim rngMatch2 As Range
  Dim lngWrite As Long
  Dim lngNumb() As Long
  Dim strProm As String

  '"vicky-com"データシートのA1を基準とします(列見出しのセル位置)
  Set rngList1 = Worksheets("vicky-com").Cells(1, "A")
  '基準に就いて
  With rngList1
    '行数を取得
    lngEnd1 = .Offset(65536 - .Row, _
            clngKeys1 - 1).End(xlUp).Row - .Row
    If lngEnd1 < 0 Then
      strProm = rngList1.Parent.Name & "にデータが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngEnd1, 1 To 1)
    For i = 1 To lngEnd1
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, clngColumns1).Resize(lngEnd1).Value = lngNumb
    'データをclngKeys1列で整列
    DataSort .Offset(1).Resize(lngEnd1, _
          clngColumns1 + 1), .Offset(1, clngKeys1 - 1)
  End With
  
  '"com"データシートのA1を基準とする(列見出しのセル位置)
  Set rngList2 = Worksheets("com").Cells(1, "A")
  '基準に就いて
  With rngList2
    '行数を取得
    lngEnd2 = .Offset(65536 - .Row, _
            clngKeys2 - 1).End(xlUp).Row - .Row
    If lngEnd2 < 0 Then
      strProm = rngList2.Parent.Name & "にデータが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngEnd2, 1 To 1)
    For i = 1 To lngEnd2
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, clngColumns2).Resize(lngEnd2).Value = lngNumb
    'データをclngKeys2列で整列
    DataSort .Offset(1).Resize(lngEnd2, _
          clngColumns2 + 1), .Offset(1, clngKeys2 - 1)
  End With
  
  '"hit"出力シートの出力位置を設定
  Set rngMatch1 = Worksheets("hit").Cells(1, "A")
  Set rngMatch2 = rngMatch1.Parent.Cells(1, "K")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '"vicky-com"シートの比較位置
  lngRow1 = 1
  '"com"シートの比較位置
  lngRow2 = 1
  '"vicky-com"シート若しくは、"com"シートが最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '各シートのデータ1行分の後半を配列に取得
    vntList1 = rngList1.Offset(lngRow1).Resize(, clngColumns1).Value
    vntList2 = rngList2.Offset(lngRow2).Resize(, clngColumns2).Value
    '比較結果に就いて
    Select Case vntList1(1, clngKeys1)
      Case Is = vntList2(1, 1) 'Matchiした場合
        '書き込み行を更新
        lngWrite = lngWrite + 1
        '"vicky-com"シートの行を"hit"シートにCopy
        rngList1.Offset(lngRow1).Resize(, clngColumns1).Copy _
            Destination:=rngMatch1.Offset(lngWrite)
        '"com"シートの行を"hit"シートにCopy
        rngList2.Offset(lngRow2).Resize(, clngColumns2).Copy _
            Destination:=rngMatch2.Offset(lngWrite)
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntList2(1, clngKeys2) '"com"シート固有値の場合
        '"com"シートの比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntList2(1, clngKeys2) '"vicky-com"シート固有値の場合
        '"vicky-com"シートの比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop

  With rngList1
    '元データを復帰
    DataSort .Offset(1).Resize(lngEnd1, _
            clngColumns1 + 1), .Offset(1, clngColumns1)
    '復帰用Key列を削除
    .Offset(, clngColumns1).EntireColumn.Delete
  End With
  With rngList2
    '元データを復帰
    DataSort .Offset(1).Resize(lngEnd2, _
            clngColumns2 + 1), .Offset(1, clngColumns2)
    '復帰用Key列を削除
    .Offset(, clngColumns2).EntireColumn.Delete
  End With

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  Set rngMatch1 = Nothing
  Set rngMatch2 = Nothing
    
  MsgBox strProm, vbInformation
  
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

0 hits

【37145】2つのシートを比較して一致する行を別シートに移動したい 小林 06/4/23(日) 14:29 質問
【37148】Re:2つのシートを比較して一致する行を別シ... ハト 06/4/23(日) 15:33 回答
【37150】Re:2つのシートを比較して一致する行を別シ... Kein 06/4/23(日) 15:46 回答
【37151】Re:2つのシートを比較して一致する行を別シ... 小林 06/4/23(日) 16:07 お礼
【37155】Re:2つのシートを比較して一致する行を別シ... Kein 06/4/23(日) 17:08 発言
【37160】Re:2つのシートを比較して一致する行を別シ... 小林 06/4/23(日) 19:35 お礼
【37154】Re:2つのシートを比較して一致する行を別シ... Hirofumi 06/4/23(日) 17:03 回答
【37161】Re:2つのシートを比較して一致する行を別シ... 小林 06/4/23(日) 19:47 お礼
【37162】Re:2つのシートを比較して一致する行を別シ... Hirofumi 06/4/23(日) 20:17 回答
【37163】Re:2つのシートを比較して一致する行を別シ... 小林 06/4/23(日) 20:32 お礼

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