Excel VBA質問箱 IV

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

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


7740 / 13645 ツリー ←次へ | 前へ→

【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 お礼[未読]

【37145】2つのシートを比較して一致する行を別シ...
質問  小林 E-MAIL  - 06/4/23(日) 14:29 -

引用なし
パスワード
   お世話になっています。
いつも参考にさせてもらっています。

2つのシートを比較して一致する行を別シートに移動したいのですが
やり方がわからず、困っています。

以下のマクロは、請求したものが支払明細にあるかの検索マクロですが、
これを変更したいのです。

Worksheets("vicky-com")は当社のデータで、com社への請求明細です。(10列あります。)
Worksheets("com")はcom社からの支払明細です。(15列あります。)
Worksheets("vicky-com")のG列は請求番号、Worksheets("com")のI列は支払番号で
当社の請求番号を使ってもらっています。(紐付けされています。)
当社の請求番号で検索して該当したらWorksheets("hit")へ、行を移動したいのです。

Worksheets("vicky-com")の該当の行(10列分)をWorksheets("hit")のAからJ列へ、Worksheets("com")の該当の行(15列分)をKからY列へ同じ行に並べて書きたいのです。

アドバイス願えないでしょうか?
よろしくお願いいたします。
Sub test()
  Dim myArea1   As Range
  Dim myArea2   As Range
  Dim R      As Range
  Dim C      As Range
  Dim SearchKey  As String
  Dim firstAddress As String
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet
  Dim ws3 As Worksheet
  
  Set ws1 = Worksheets("vicky-com")
  Set ws2 = Worksheets("com")
  Set ws3 = Worksheets("hit")
  Set myArea1 = ws1.Range("G1", Range("G65536").End(xlUp))
  Set myArea2 = ws2.Range("I:I")

  For Each R In myArea1
    SearchKey = R.Value
    Set C = myArea2.Find(What:=SearchKey, LookIn:=xlValues, LookAt:=xlWhole)
  
    If Not C Is Nothing Then
      firstAddress = C.Address
      Do
        R.Offset(, 4).Value = "該当"
        Set C = myArea2.FindNext(C)
      Loop While Not C Is Nothing And C.Address <> firstAddress
    End If
  Next R

End Sub

【37148】Re:2つのシートを比較して一致する行を別...
回答  ハト  - 06/4/23(日) 15:33 -

引用なし
パスワード
   こんにちは、ハトです。
小林さんのに付け加える形で考えてみました
もっとうまいやり方があるかもしれませんが、試してみてください

▼小林 さん:
>お世話になっています。
>いつも参考にさせてもらっています。
>
>2つのシートを比較して一致する行を別シートに移動したいのですが
>やり方がわからず、困っています。
>
>以下のマクロは、請求したものが支払明細にあるかの検索マクロですが、
>これを変更したいのです。
>
>Worksheets("vicky-com")は当社のデータで、com社への請求明細です。(10列あります。)
>Worksheets("com")はcom社からの支払明細です。(15列あります。)
>Worksheets("vicky-com")のG列は請求番号、Worksheets("com")のI列は支払番号で
>当社の請求番号を使ってもらっています。(紐付けされています。)
>当社の請求番号で検索して該当したらWorksheets("hit")へ、行を移動したいのです。
>
>Worksheets("vicky-com")の該当の行(10列分)をWorksheets("hit")のAからJ列へ、Worksheets("com")の該当の行(15列分)をKからY列へ同じ行に並べて書きたいのです。
>
>アドバイス願えないでしょうか?
>よろしくお願いいたします。
>Sub test()
>  Dim myArea1   As Range
>  Dim myArea2   As Range
>  Dim R      As Range
>  Dim C      As Range
>  Dim SearchKey  As String
>  Dim firstAddress As String
>  Dim ws1 As Worksheet
>  Dim ws2 As Worksheet
>  Dim ws3 As Worksheet

'ws3での行カウント用カウンタ
  Dim pos As Long

>  
>  Set ws1 = Worksheets("vicky-com")
>  Set ws2 = Worksheets("com")
>  Set ws3 = Worksheets("hit")
>  Set myArea1 = ws1.Range("G1", Range("G65536").End(xlUp))
>  Set myArea2 = ws2.Range("I:I")

'カウンタの初期化、画面更新抑止
  pos = 1
  Application.ScreenUpdating = False

>
>  For Each R In myArea1
>    SearchKey = R.Value
>    Set C = myArea2.Find(What:=SearchKey, LookIn:=xlValues, LookAt:=xlWhole)
>  
>    If Not C Is Nothing Then
>      firstAddress = C.Address
>      Do
>        R.Offset(, 4).Value = "該当"

'ws1の該当行(A列からJ列)をws3(A列からJ列)へコピー
        ws1.Select
        ws1.Range(Cells(R.Row, 1), Cells(R.Row, 10)).Copy _
          Destination:=ws3.Cells(pos, 1)
        
'ws2の該当行(A列からO列)をws3(K列からY列)へコピー
        ws2.Select
        ws2.Range(Cells(C.Row, 1), Cells(C.Row, 15)).Copy _
          Destination:=ws3.Cells(pos, 11)

'ws3の書込み行のカウンタを更新        
        pos = pos + 1

>        Set C = myArea2.FindNext(C)
>      Loop While Not C Is Nothing And C.Address <> firstAddress
>    End If
>  Next R

'画面更新再開
  ws1.Select
  Application.ScreenUpdating = True

>
>End Sub

【37150】Re:2つのシートを比較して一致する行を別...
回答  Kein  - 06/4/23(日) 15:46 -

引用なし
パスワード
   Worksheets("vicky-com")の AG列 を作業列として数式を埋め込んで検索し、
ヒットした行を転記処理する。というコードなら・・

Sub Data_Serch_Copy()
  Dim MyR As Range, CpR As Range
  Dim C As Range, PsR As Range
  Dim Cr As Long
  Dim MyV1 As Variant, MyV2 As Variant

  With Worksheets("vicky-com")
   Set MyR = .Range("G1", .Range("G65536").End(xlUp)) _
   .Offset(, 26)
   Set CpR = .Range("A:J")
  End With
  MyR.Formula = "=MATCH($G1,com!$I:$I,0)"
  On Error GoTo ELinee
  Set MyR = MyR.SpecialCells(3, 1)
  On Error GoTo 0
  'Worksheets("hit").Cells.ClearContents
  '↑コピー先のデータを全て入れ替えする場合は、コメントを外す。
  For Each C In MyR
   Cr = C.Value
   MyV1 = Intersect(C.EntireRow, CpR).Value
   MyV2 = Worksheets("com").Cells(Cr, 1).Resize(, 15).Value
   Set PsR = Worksheets("hit").Range("A65536").End(xlUp)
   PsR.Offset(1).Resize(, 10).Value = MyV1
   PsR.Offset(1, 10).Resize(, 15).Value = MyV2
   Set PsR = Nothing
  Next
ELine:
  Set MyR = Nothing: Set CpR = Nothing
  Worksheets("vicky-com").Range("AG:AG").ClearContents
  If Err.Number <> 0 Then
   MsgBox "請求番号がヒットした支払番号はありませんでした", 48
  Else
   Worksheets("hit").Activate
  End If
End Sub    

【37151】Re:2つのシートを比較して一致する行を別...
お礼  小林 E-MAIL  - 06/4/23(日) 16:07 -

引用なし
パスワード
   ▼ハトさん、Kein さん:

お二方様、こんなに早くありがとうございました。

どちらもバッチリです。
期待どうりの結果が得られました。
助かりました。

本当にありがとうございました。

【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

【37155】Re:2つのシートを比較して一致する行を別...
発言  Kein  - 06/4/23(日) 17:08 -

引用なし
パスワード
   すいません、タイプミスがありました。
>On Error GoTo ELinee


On Error GoTo ELine

失礼しました。

【37160】Re:2つのシートを比較して一致する行を別...
お礼  小林 E-MAIL  - 06/4/23(日) 19:35 -

引用なし
パスワード
   ▼Kein さん:
ご丁寧にありがとうございました。
実験したときこの行が反転したのでタイプミスは問題なくクリアしました。
連絡が遅れて申し訳ありませんでした。
ありがとうございました。

>すいません、タイプミスがありました。
>>On Error GoTo ELinee
>↓
>
>On Error GoTo ELine
>
>失礼しました。

【37161】Re:2つのシートを比較して一致する行を別...
お礼  小林 E-MAIL  - 06/4/23(日) 19:47 -

引用なし
パスワード
   ▼Hirofumi さん:
ご回答ありがとうございます。

こちらの環境(Excel2002)では、マクロ実行時に
画面左下に「並べ替えのプログレスバー」が出っ放しで
無応答になってしまいました。

デバッグ→ステップインF8でやると
Do Loopが延々と繰り返してしまいました。

(僕にとって)あまりに高度なマクロなので理解し切れていないので
もう少し勉強させてもらいます。

大変ありがとうございました。
Keyの重複は、当社の担当者がタイプミスした時意外はありえないので
別途回避したいと思います。

皆様、ありがとうございました。

【37162】Re:2つのシートを比較して一致する行を別...
回答  Hirofumi  - 06/4/23(日) 20:17 -

引用なし
パスワード
   >こちらの環境(Excel2002)では、マクロ実行時に
>画面左下に「並べ替えのプログレスバー」が出っ放しで
>無応答になってしまいました。
>
>デバッグ→ステップインF8でやると
>Do Loopが延々と繰り返してしまいました。
>
>(僕にとって)あまりに高度なマクロなので理解し切れていないので
>もう少し勉強させてもらいます。

ゴメン、1部間違っていました

      Case Is = vntList2(1, 1) 'Matchiした場合


      Case Is = vntList2(1, clngKeys2) 'Matchiした場合

でした、修正して全文Upします

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, clngKeys2) '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

【37163】Re:2つのシートを比較して一致する行を別...
お礼  小林 E-MAIL  - 06/4/23(日) 20:32 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございました。
バッチリです。

こんなに素早く対応して頂いて本当にありがとうございます。

皆様に感謝いたします。
今後ともよろしくお願いいたします。
ありがとうございました。

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