Excel VBA質問箱 IV

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

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


13161 / 13646 ツリー ←次へ | 前へ→

【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 お礼

【6745】シート間の重複チェック
質問  中村  - 03/7/30(水) 17:59 -

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

【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()を実行してみて下さい。

【6748】Re:シート間の重複チェック訂正
発言  ichinose  - 03/7/31(木) 8:05 -

引用なし
パスワード
   逆でしたね!!

>例えば、・・・
>シート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)
  Set shtrng1 = get_rng(Worksheets("シート1"), 1)
  If shtrng1 Is Nothing Then
    If Not shtrng2 Is Nothing Then
     shtrng2.EntireRow.Delete
     End If
  Else
    If Not shtrng2 Is Nothing Then
     For Each crng In shtrng2
       If find_rng(crng, shtrng1) = False Then
        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()を実行してみて下さい。

【6750】Re:シート間の重複チェック訂正
お礼  中村 E-MAIL  - 03/7/31(木) 8:40 -

引用なし
パスワード
   ichinoseさん、早速のご返答ありがとうございました。
一度試してみます、又何かありましたら、
お尋ねさせて頂きます。ありがとうございました。

【6751】シート間の重複チェック再度
質問  中村 E-MAIL  - 03/7/31(木) 9:16 -

引用なし
パスワード
   ichinoseさん、再度すみません。説明不足で・・
シート2には、
>  A     B
>1 コード   名称
>2  1     A
>3  2     B
>4  3     C
>5  4     D
>6  5     E
>7  6     F
>8  7     G
>
>とデータがあり、シート1には、
>
>  A  
>1 コード
>2  1 
>3  3 
>4  4
>6  7
>7  6
>
とデータがあった場合、シート2でシート1に登録されていない「2」と「5」を
削除したいです。簡単に申しますと、シート1に登録されているデータだけを
シート2に出せればokです。

結果シート2
>  A     B
>1 コード   名称
>2  1     A
>3  3     C
>4  4     D
>5  6     F
>6  7     G

シート2にはシート1のデータを全て持っています。
シート1にはコードの列しかございません。

説明不足で申し訳ございません。

【6752】Re:シート間の重複チェック再度
発言  ichinose  - 03/7/31(木) 9:25 -

引用なし
パスワード
   ▼中村 さん:
はい、私が間違えていました。
訂正版のほうを試してみて下さい。

【6753】ありがとうございました。
お礼  中村  - 03/7/31(木) 10:15 -

引用なし
パスワード
   ichinoseさん、
ありがとうございました、できました。
お忙しいところ申し訳御座いません。
処理速度も速いです。

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