Excel VBA質問箱 IV

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

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


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

【43566】同一列内に同一データ検索 Help me!! 06/10/19(木) 11:51 質問[未読]
【43573】Re:同一列内に同一データ検索 06/10/19(木) 12:53 発言[未読]
【43627】Re:同一列内に同一データ検索 Help me!! 06/10/20(金) 9:54 お礼[未読]
【43578】Re:同一列内に同一データ検索 Kein 06/10/19(木) 14:05 回答[未読]
【43579】Re:同一列内に同一データ検索 Kein 06/10/19(木) 14:09 発言[未読]
【43629】Re:同一列内に同一データ検索 Help me!! 06/10/20(金) 9:57 質問[未読]
【43635】Re:同一列内に同一データ検索 Kein 06/10/20(金) 15:25 発言[未読]
【43692】Re:同一列内に同一データ検索 Help me!! 06/10/23(月) 10:51 お礼[未読]

【43566】同一列内に同一データ検索
質問  Help me!!  - 06/10/19(木) 11:51 -

引用なし
パスワード
   いつもココで勉強させてもらっています。
今回もよろしくお願いします。

今回やりたいことは、エクセルの同一の列内に同一のデータが存在するかしないかを判定するマクロを作りたいです。
また、検索する列を実行時に選択出来るようにしたいです。(inputboxか何かでA,とかB、とか列名を指定したいです。)

言葉では表しにくいので表を書きます。

   A列   B列
1行 佐藤   2
2行 鈴木   3
3行 伊藤   2
4行 佐藤   1

とあった場合。
マクロ実行時にA列をしてしたら、別のシート(新規にシート作成)に「佐藤」と表示されれば最高です!
また別例で上記の表で検索をB列に指定したら別のシート(新規にシート作成)に「2」と表示されれば最高です!

どなたかご教授のほどよろしくお願いします。

     

【43573】Re:同一列内に同一データ検索
発言    - 06/10/19(木) 12:53 -

引用なし
パスワード
   新規シートでなく、イミディエイトウィンドウに表示ですが・・・。
これは以前このページで見つけたものです。
私は初心者なので、そのままコピペで貼りつけました。
ご参考までに



Sub Check_Uniq_Data()
  Debug.Print "[ 重複のあるデータ ]"
  On Error Resume Next
  With Range("A1", Range("A65536").End(xlUp)).Offset(, 255)
   .Formula = _
   "=IF(AND(COUNTIF(A:A,A1)>1,MATCH(A1,A:A,0)=ROW()),A1,0)"            'A列中の重複データを探す。
   For Each C In .SpecialCells(3, 2)
     Debug.Print C.Value
   Next
   .ClearContents
  End With
  On Error GoTo 0
  SendKeys "^(g)", True
End Sub

【43578】Re:同一列内に同一データ検索
回答  Kein  - 06/10/19(木) 14:05 -

引用なし
パスワード
   結果を表示するシートは、必ず「ブックの左端にあり」「Resultという名前である」
ということにします。現在無ければ、ダブルクリック実行時に自動的に追加します。
>inputboxか何か
に値を入力して指定するのは煩わしいので「ダブルクリックしたセルの列」を
対象にします。従ってイベントマクロになりますから、シートモジュールに
入れて下さい。コードは・・

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
  Dim Sh As Worksheet
  Dim Col As Integer, Col2 As Integer
   
  Col = Target.Column
  If Col = 256 Then Exit Sub
  Col2 = (256 - Col) * -1
  If WorksheetFunction.CountA(Columns(Col)) < 2 Then Exit Sub
  Range("IV:IV").ClearContents
  Intersect(Columns(Col).SpecialCells(2).EntireRow, Range("IV:IV")) _
  .FormulaR1C1 = "=IF(COUNTIF(R1C[" & Col2 & "]:RC[" & Col2 & _
  "],RC[" & Col2 & "])=2,RC[" & Col2 & "],FALSE)"
  Cancel = True: Set Sh = ActiveSheet
  Range("IV:IV").SpecialCells(3, 4).ClearContents
  On Error Resume Next
  If Worksheets(1).Name <> "Result" Then
   Worksheets.Add(Before:=Worksheets(1)).Name = "Result"
  End If
  On Error GoTo 0
  With Worksheets("Result")
   If .Index > 1 Then .Move Before:=Worksheets(1)
   .Columns(Col).ClearContents
   Sh.Range("IV:IV").SpecialCells(3).Copy
   .Cells(1, Col).PasteSpecial xlPasteValues
   Application.Goto .Cells(1, Col), True
  End With
  Sh.Range("IV:IV").ClearContents: Set Sh = Nothing
  Application.CutCopyMode = False
End Sub

ただし、IV列(シートの最終列)のみは作業列とするので、
ダブルクリックは無効になります。もちろん、値が1つ以下しか
入力されていない列でダブルクリックした場合も、マクロは中止します。
正常に重複値をコピーできた場合、Resultシートを開き、ダブルクリック
した列までスクロールして終了します。

【43579】Re:同一列内に同一データ検索
発言  Kein  - 06/10/19(木) 14:09 -

引用なし
パスワード
   一つ修正があります。
>On Error GoTo 0
は、削除しておいて下さい。

【43627】Re:同一列内に同一データ検索
お礼  Help me!!  - 06/10/20(金) 9:54 -

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

ありがとうございます!参考になりました!!

【43629】Re:同一列内に同一データ検索
質問  Help me!!  - 06/10/20(金) 9:57 -

引用なし
パスワード
   ▼Kein さん:
すごい!すごい!!すごすぎます!!
本当に感動しました。

でも一つだけ出来れば直して欲しい事があります。
ダブルクリックでマクロ開始はすごくありがたいのですが、出来れば一番上の行(項目行)だけ反応するようにできませんか?

わがままばかりで申し訳ございませんが、何卒ご教授のほどよろしくお願いします。

【43635】Re:同一列内に同一データ検索
発言  Kein  - 06/10/20(金) 15:25 -

引用なし
パスワード
   >一番上の行(項目行)だけ反応
コードの先頭に一行追加するだけです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
  Dim Sh As Worksheet
  Dim Col As Integer, Col2 As Integer

  If Target.Row > 1 Then Exit Sub '←これを追加   
  Col = Target.Column

【43692】Re:同一列内に同一データ検索
お礼  Help me!!  - 06/10/23(月) 10:51 -

引用なし
パスワード
   ▼Kein さん:
本当に助かりました。
これで上司に怒られなくてすみます。
今まではずっと目で確認していたのですが、やはり目では限界があるみたいで見落としてました。
これがあれば簡単に事が進みます!
本当にありがとうございました!

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