Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1942 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【70985】ﾃﾞｰﾀが同じ行の削除 doka 12/1/24(火) 8:41 質問[未読]
【70987】Re:ﾃﾞｰﾀが同じ行の削除 Yuki 12/1/24(火) 9:37 回答[未読]
【70990】Re:ﾃﾞｰﾀが同じ行の削除 doka 12/1/24(火) 15:24 お礼[未読]
【70988】Re:ﾃﾞｰﾀが同じ行の削除 kanabun 12/1/24(火) 10:02 発言[未読]
【70991】Re:ﾃﾞｰﾀが同じ行の削除 doka 12/1/24(火) 15:36 質問[未読]
【71012】Re:ﾃﾞｰﾀが同じ行の削除 doka 12/1/26(木) 7:29 お礼[未読]
【71013】Re:ﾃﾞｰﾀが同じ行の削除 kanabun 12/1/26(木) 8:59 発言[未読]
【71032】Re:ﾃﾞｰﾀが同じ行の削除 doka 12/1/26(木) 22:26 お礼[未読]
【70985】ﾃﾞｰﾀが同じ行の削除
質問  doka  - 12/1/24(火) 8:41 -
引用なし
パスワード
   B〜Z列までﾃﾞｰﾀが入っている行が１００行あります。
B〜Z列までの各セルの値が全て同じ行が２つある場合は、最初の行の列のセルの背景を目印となる黄色をつけたいのです。

どなたかマクロを作成してください。
お願いいたします。

できればソートはしたくないです。

　　　　A　　B　　C　・・・　　Z
１　　　　　 7　　8　　　　　　9
２　　　　 　2　　5　　　　　　7　　←　51行と同じなので背景を黄色
３　　　　 　2　　　　　5
・
・
５１　　 　　2　　5　　　　　　7
【70987】Re:ﾃﾞｰﾀが同じ行の削除
回答  Yuki  - 12/1/24(火) 9:37 -
引用なし
パスワード
   ▼doka さん：
>B〜Z列までﾃﾞｰﾀが入っている行が１００行あります。
>B〜Z列までの各セルの値が全て同じ行が２つある場合は、最初の行の列のセルの背景を目印となる黄色をつけたいのです。
>
こんにちは。
チョット遅いかもしれませんが
こんな感じでどうでしょう。

Sub TESTa()
　　Dim v1　As Variant
　　Dim Dic As Object
　　Dim i　 As Long
　　
　　Set Dic = CreateObject("Scripting.Dictionary")
　　With Worksheets("Sheet1")
　　　　.Cells.Interior.ColorIndex = xlNone
　　　　For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
　　　　　　v1 = .Cells(i, 1).Resize(, 26).Value
　　　　　　v1 = WorksheetFunction.Index(v1, 0)
　　　　　　v1 = Join(v1, vbTab)
　　　　　　If Dic.Exists(v1) Then
　　　　　　　　Debug.Print Dic(v1)
　　　　　　　　.Cells(Dic(v1), 1).Resize(, 26).Interior.ColorIndex = 6
　　　　　　Else
　　　　　　　　Dic(v1) = i
　　　　　　End If
　　　　Next
　　End With
End Sub
【70988】Re:ﾃﾞｰﾀが同じ行の削除
発言  kanabun  - 12/1/24(火) 10:02 -
引用なし
パスワード
   ▼doka さん：
Dictionary（辞書）オブジェクトを使うと、こんな風に処理が
できます。

Sub Try1()
　　Dim r As Range
　　Dim dic As Object
　　Dim ss As String　'1行データパターン
　　Dim n As Long
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　With Range("B1:Z51")
　　　　.Interior.ColorIndex = xlNone
　　　　For Each r In .Rows
　　　　　　n = n + 1　'処理行
　　　　　　'一行をTab区切り文字列に変換
　　　　　　ss = Join(Application.Index(r.Value, 0#), vbTab)
　　　　　　If dic.Exists(ss) Then
　　　　　　　　If dic(ss) > 0 Then
　　　　　　　　　　.Rows(dic(ss)).Interior.ColorIndex = 6
　　　　　　　　　　dic(ss) = -dic(ss) '先頭行に色塗り,完了
　　　　　　　　End If
　　　　　　Else
　　　　　　　　dic(ss) = n　'初出パターン
　　　　　　End If
　　　　Next
　　End With
　　
　　Set dic = Nothing
　　　　　　　　　　
End Sub

>　　　　For Each r In .Rows
から処理開始です。これは [B1:Z51]の範囲を Row単位で処理を
くり返す、という命令です。

>　　　　　　'一行をTab区切り文字列に変換
>　　　　　　ss = Join(Application.Index(r.Value, 0#), vbTab)
ここはコメントにある通り、範囲のうち1行を１つの文字列に連結して
いるところです。
範囲1行目が　7 8 6　 6　....　 9
としますと、上の処理により
　　ss = "7・8・6・・6・....・・9"　 （・はTabコード）
というある文字列となります。
2行目データですと
　　ss = "2・5・・・・....・6・7"　 （・はTabコード）
です。
この1行パターンss を辞書に登録していけば（登録するとき、初出行番号
と組で登録します）、
たとえば 51行目のパターン
　　ss = "2・5・・・・....・6・7"　 （・はTabコード）
が、すでに辞書の中にあるか？ は
↓のようにして調べることが可能ですから、
>　　　　　　If dic.Exists(ss) Then　'ss が存在すればTrueが返る
51行目のパターンのとき True が返りますので、
すぐ次の行でこのパターンの初出行番号を調べ、
その行を黄色に塗りつぶし、
塗りつぶしが終わったしるしに 格納した行番号をマイナスにしておきます。
>　　　　　　　　If dic(ss) > 0 Then
>　　　　　　　　　　.Rows(dic(ss)).Interior.ColorIndex = 6
>　　　　　　　　　　dic(ss) = -dic(ss) '先頭行に色塗り,完了
【70990】Re:ﾃﾞｰﾀが同じ行の削除
お礼  doka  - 12/1/24(火) 15:24 -
引用なし
パスワード
   ▼Yuki さん　回答ありがとうございます

試してみましたが、何も起こらず、期待した動きはしませんでした。
【70991】Re:ﾃﾞｰﾀが同じ行の削除
質問  doka  - 12/1/24(火) 15:36 -
引用なし
パスワード
   ▼kanabun さん　回答ありがとうございます。
私の一方的なお願いが、あっさりも、こんなシンプルなコードで実現できるなんて驚きです。

また、コードも解説がなければ分からない難解なもので、解説付きで助かりました。

実行して気が付いたのですが、ちょっと仕様を変えたいところがあります。

１〜５０行までと５１〜１００行までの二つの領域を比較して、５１〜１００行までのﾃﾞｰﾀと同じものが、１〜５０行目までの中にあった場合、１〜５０行のほうに色をつけるとしたいのですが、お願いいたします。
【71012】Re:ﾃﾞｰﾀが同じ行の削除
お礼  doka  - 12/1/26(木) 7:29 -
引用なし
パスワード
   ▼kanabun さん　回答ありがとうございました。

教えていただいたことを利用すれば、やりたいことが簡単に実現できました。

（自分用の単なるメモのようなものですが載せておきます）

Sub Try1()
　　Dim r As Range
　　Dim dic As Object
　　Dim ss As String　'1行データパターン
　　Dim n As Long
　
　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　'比較する範囲
　　With Range("B10:E20")
　　　　.Interior.ColorIndex = xlNone
　　　　For Each r In .Rows
　　　　　　n = n + 1　'処理行
　　　　　　'一行をTab区切り文字列に変換
　　　　　　ss = Join(Application.Index(r.Value, 0#), vbTab)
　　　　　　If dic.Exists(ss) Then

　　　　　　Else
　　　　　　　　dic(ss) = n　'初出パターン
　　　　　　End If
　　　　　
　　　　Next
　
　　End With
　
　　'比較されて消される範囲
　　　With Range("B1:E10")
　　　　.Interior.ColorIndex = xlNone
　　　　For Each r In .Rows
　　　　
　　　　　　n = r.Row '処理行
　　　　　　'一行をTab区切り文字列に変換
　　　　　　ss = Join(Application.Index(r.Value, 0#), vbTab)

　　　　　　If dic.Exists(ss) Then
　　　　　　　　　　.Rows(n).Interior.ColorIndex = 6
　　　　　　Else
　　　　　　　　dic(ss) = n　'初出パターン
　　　　　　End If
　　　　　
　　　　Next
　　　　
　　End With
　
　　Set dic = Nothing
　　　　　
End Sub
【71013】Re:ﾃﾞｰﾀが同じ行の削除
発言  kanabun  - 12/1/26(木) 8:59 -
引用なし
パスワード
   ▼doka さん：

>教えていただいたことを利用すれば、やりたいことが簡単に実現できました。
ごめん。レスして、すぐ外出してネットにアクセスできない環境にいたもので、
Yukiさんのコードが前に出ていて、自分のがYukiさんのコードのパクリみたい
になってるの、気が付きませんでした m(_ _)m
Yukiさんのコードがそのままでは変化がなかったのは、たぶん処理対象範囲の
ちょっとしたちがいから？

> １〜５０行までと５１〜１００行までの二つの領域を比較して、
> ５１〜１００行までのﾃﾞｰﾀと同じものが、１〜５０行目までの中に
> あった場合、１〜５０行のほうに色をつけるとしたいのですが、

doka さん の直されたコードを
「てにおは」部分だけ、ちょっと編集してみました。(^^)
Sub Try2()
　　Dim r As Range
　　Dim dic As Object
　　Dim ss As String　'1行データパターン

　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　'比較する範囲
　　With Range("B10:E20")
　　　　For Each r In .Rows '行単位で
　　　　　　'一行をTab区切り文字列に変換
　　　　　　ss = Join(Application.Index(r.Value, 0#), vbTab)
　　　　　　dic(ss) = Empty '一行パターンを辞書に登録
　　　　Next
　　End With
　
　　'比較されて消される範囲
　　With Range("B1:E10")
　　　　.Interior.ColorIndex = xlNone
　　　　For Each r In .Rows　'行単位で調査
　　　　　　'一行をTab区切り文字列に変換
　　　　　　ss = Join(Application.Index(r.Value, 0#), vbTab)
　　　　　　If dic.Exists(ss) Then
　　　　　　　　r.Interior.ColorIndex = 6
　　　　　　End If
　　　　Next
　　End With
　
　　Set dic = Nothing
　　
End Sub
【71032】Re:ﾃﾞｰﾀが同じ行の削除
お礼  doka  - 12/1/26(木) 22:26 -
引用なし
パスワード
   ▼kanabun さん　回答ありがとうございます

「てにおは」こんな言葉があるのですね。初めて知りました。
何度もありがとうございました。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1942 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free