Excel VBA質問箱 IV

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

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


12190 / 13644 ツリー ←次へ | 前へ→

【11865】重複セルの削除 カド 04/3/17(水) 18:48 質問
【11866】Re:重複セルの削除 Asaki 04/3/17(水) 20:08 回答
【11868】Re:重複セルの削除 ichinose 04/3/17(水) 21:10 回答
【11869】Re:重複セルの削除 カド 04/3/17(水) 21:53 お礼
【11870】Re:重複セルの削除 Hirofumi 04/3/17(水) 21:56 回答
【11871】Re:重複セルの削除 カド 04/3/17(水) 23:09 お礼

【11865】重複セルの削除
質問  カド E-MAIL  - 04/3/17(水) 18:48 -

引用なし
パスワード
   選択しているn列において重複しているデーターが有った場合は、
そのデーターがある最後の行を残して、その他の行は削除してしまいたいのです。

一般的な?コードは、最初にソートするため順番が変わってしまいますが、
順番は変えずに出来ないでしょうか?

また行を削除するとは、データを消して空白行を残すのではなく、
行そのものを削除するものとします。

一から書いてもらうのは大変申し訳ないので、既に作成ずみのコードがあれば
教えていただくか、フリーソフトなどでご存知のものがあれば紹介ください。

【11866】Re:重複セルの削除
回答  Asaki  - 04/3/17(水) 20:08 -

引用なし
パスワード
   こんばんは。

フィルタオプションの「重複するレコードは無視する」で抽出、
辺りが応用できそうです。
マクロの記録を試してみては如何でしょうか?

>一から書いてもらうのは大変申し訳ないので、既に作成ずみのコードがあれば
>教えていただくか、フリーソフトなどでご存知のものがあれば紹介ください。
あくまでも、コードを書くのは、あなたです。
掲示板は、その上で、わからない部分があれば、解る人がお手伝いする場かと思います。

【11868】Re:重複セルの削除
回答  ichinose  - 04/3/17(水) 21:10 -

引用なし
パスワード
   ▼カド さん:
こんばんは。
>選択しているn列において重複しているデーターが有った場合は、
>そのデーターがある最後の行を残して、その他の行は削除してしまいたいのです。
>
>一般的な?コードは、最初にソートするため順番が変わってしまいますが、
>順番は変えずに出来ないでしょうか?
>
>また行を削除するとは、データを消して空白行を残すのではなく、
>行そのものを削除するものとします。
>
>一から書いてもらうのは大変申し訳ないので、既に作成ずみのコードがあれば
>教えていただくか、フリーソフトなどでご存知のものがあれば紹介ください。


以下のコードは、
 例えば、下のようなデータがA列、B列の1行目からあったとします。

A    B
1    a
2    b
3    c
4    d
5    a
6    b
7    c
8    d
9    a
10    b
11    c
12    d

この時、セルB1〜B12を選択して、後述するマクロを実行して下さい。

結果は、
A    B
9    a
10    b
11    c
12    d

となります。大体こういう仕様ですよね?

尚、作業エリアとして、アクティブシートの次のシート(右隣のシート)
を使用しますので、用意して置いて下さい。

標準モジュールに
'================================================================
Sub main()
  Dim rng As Range
  Dim ans As Range
  Set rng = Selection
  If rng.Count <= 1 Then
   Exit Sub
   End If
  Set ans = get_dup_last_rng(rng, ActiveSheet.Next, False)
  If Not ans Is Nothing Then
   ans.EntireRow.Delete
   End If
End Sub
'================================================================
Function get_dup_last_rng(rng As Range, sht As Worksheet, v_or_b As Boolean)
  'rng : 重複チェックセル範囲
  'sht : 作業シート
  'v_or_b: true  重複処理後、データと認識されるセル範囲の取得
  '    false 重複処理後、データと認識しないセル範囲を取得
  Dim motosht As Worksheet
  Dim wk As Range
  Set motosht = rng.Parent
  sht.Cells.ClearContents
  addr1 = rng.Cells(1).Address(False, False, , True)
  addr2 = rng.Cells(1).Address(, , , True) & ":" & addr1
  addr3 = rng.Address(, , , True)
  With sht.Range(rng.Address)
   .Formula = "=IF(COUNTIF(" & addr2 & "," & addr1 & _
         ")=COUNTIF(" & _
         addr3 & "," & addr1 & ")," & _
         addr1 & ","""")"
   .Value = .Value
   On Error Resume Next
   If v_or_b = True Then
   
     Set wk = .SpecialCells(xlCellTypeConstants)
   Else
     Set wk = .SpecialCells(xlCellTypeBlanks)
     End If
   If Err.Number <> 0 Then
     Set get_dup_last_rng = Nothing
   Else
     Set get_dup_last_rng = motosht.Range(wk.Address)
     End If
   .Parent.Cells.ClearContents
   End With
   
End Function

確認してみて下さい。

【11869】Re:重複セルの削除
お礼  カド E-MAIL  - 04/3/17(水) 21:53 -

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

わざわざこのような長文ありがとう御座います。
もちろんバッチリ行きました。

あと、ケインさん作の以下のコードもありました。

これは重複する上側の行を残すものですが、上下が逆になるようソートしてから実行すれば
同じ効果が得られると思います。

Sub Test()
  Dim i As Long, MyR As Range

  Application.ScreenUpdating = False
  For i = Cells(65536, 1).End(xlUp).Row To 1 Step -1
   Set MyR = Range("A1", Range("A65536").End(xlUp))
   If WorksheetFunction.CountIf(MyR, Cells(i, 1).Value) > 1 Then
     Rows(i).Delete xlShiftUp '行全体をつめる
     'Cells(i, 1).ClearContents’行をつめない
     'Cells(i, 1).Delete xlShiftUp'行をつめる
   End If
   Set MyR = Nothing
  Next i
 
End Sub

【11870】Re:重複セルの削除
回答  Hirofumi E-MAIL  - 04/3/17(水) 21:56 -

引用なし
パスワード
   Dictionaryオブジェクトを使ってこんなのでも善いかも?
ただし、基本的な事しかやって無いので、2列以上選択した場合等は考慮していません

Public Sub Test()

  Dim i As Long
  Dim lngTop As Long
  Dim lngEnd As Long
  Dim lngCol As Long
  Dim vntTmp As Variant
  Dim dicIndex As Object
  
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  lngTop = Selection.Row
  lngEnd = lngTop + Selection.Rows.Count - 1
  lngCol = Selection.Column
  
  With dicIndex
    For i = lngEnd To lngTop Step -1
      vntTmp = Cells(i, lngCol).Value
      If .Exists(vntTmp) Then
        Rows(i).Delete
      Else
        .Add vntTmp, i
      End If
    Next i
  End With
  
  Set dicIndex = Nothing
  
End Sub

【11871】Re:重複セルの削除
お礼  カド E-MAIL  - 04/3/17(水) 23:09 -

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

確認したらうまく行きました。

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