Excel VBA質問箱 IV

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

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


74451 / 76732 ←次へ | 前へ→

【6747】Re:シート間の重複チェック
回答  ichinose  - 03/7/31(木) 7:43 -

引用なし
パスワード
   ▼中村 さん:
おはようございます。
>はじめまして、中村と申します。
>早速ですが、どなたかヘルプ願います。
>シート1のA列には見だし〜番号データがバラバラにあります。A列のみにデータあり。
>シート2のA列にも見だし〜番号データがバラバラにあります。B列にもデータあり。
>シート2には全データがあり、シート1にはシート2の一部のデータがあります。
>結果的に、シート2とシート1のA列で重複チェックして、
>シート2はシート1の番号データにマッチした分だけのシートにしたいのです。
>説明不足ですみませんが、宜しくお願いします。

例えば、・・・
シート2には、
  A     B
1 コード   名称
2  1     A
3  2     B
4  3     C
5  4     D
6  5     E
7  6     F

とデータがあり、シート1には、

  A  
1 コード
2  1 
3  3 
4  4
6  7
7  6

とデータがあった場合、シート1でシート2に登録されていない6行目の「7」を
削除したいということでしょうか?
'============================================================
Sub main()
  Dim shtrng2 As Range
  Dim shtrng1 As Range
  Dim crng As Range
  Dim delrng As Range
  Set shtrng2 = get_rng(Worksheets("シート2"), 1)
  '↑シート2のA列のデータ範囲を取得
  Set shtrng1 = get_rng(Worksheets("シート1"), 1)
  '↑シート1のA列のデータ範囲を取得
  If shtrng2 Is Nothing Then  'シート2にデータなし?
    If Not shtrng1 Is Nothing Then 'シート1にデータがあった
     shtrng1.EntireRow.Delete
     End If
  Else
    If Not shtrng1 Is Nothing Then
     For Each crng In shtrng1
       If find_rng(crng, shtrng2) = False Then
       '  ↑シート2に同じデータがあるかチェック 
        If Not delrng Is Nothing Then
          Set delrng = Union(delrng, crng)
        Else
          Set delrng = crng
          End If
        End If
       Next crng
     If Not delrng Is Nothing Then
       delrng.EntireRow.Delete
       End If
     End If
    End If
End Sub
'============================================================
Function get_rng(sht As Worksheet, fcol As Long) As Range
  With sht
    Set get_rng = .Range(.Cells(2, fcol), .Cells(.Rows.Count, fcol).End(xlUp))
    End With
  If get_rng.Row = 1 Then
    Set get_rng = Nothing
    End If
End Function
'===========================================================
Function find_rng(rng1 As Range, rng2 As Range) As Boolean
  On Error Resume Next
  find_rng = True
  wk = WorksheetFunction.Match(rng1, rng2, 0)
  If Err.Number <> 0 Then find_rng = False
  On Error GoTo 0
End Function

でmain()を実行してみて下さい。

0 hits

【6745】シート間の重複チェック 中村 03/7/30(水) 17:59 質問
【6747】Re:シート間の重複チェック ichinose 03/7/31(木) 7:43 回答
【6748】Re:シート間の重複チェック訂正 ichinose 03/7/31(木) 8:05 発言
【6750】Re:シート間の重複チェック訂正 中村 03/7/31(木) 8:40 お礼
【6751】シート間の重複チェック再度 中村 03/7/31(木) 9:16 質問
【6752】Re:シート間の重複チェック再度 ichinose 03/7/31(木) 9:25 発言
【6753】ありがとうございました。 中村 03/7/31(木) 10:15 お礼

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