Results of 1 - 1 of about 48828 for A�����������������������... (0.010 sec.)
- [[20170220002841]]
- #score: 1420
- @digest: a0fe69749b1547ce9e8ab495c0842482
- @id: 72749
- @mdate: 2017-02-21T09:29:34Z
- @size: 29871
- @type: text/plain
- #keywords: 複者 (53414), vbnewline (30028), あ, (28039), 赤) (27884), msg2 (26825), タ領 (22515), ルdi (15571), msg (14514), 赤文 (11379), 力( (10542), 重複 (10266), 着色 (8086), vbred (7823), ジボ (7712), 力ミ (7660), flag (6135), 領域 (5585), 未入 (5539), font (5123), colorindex (5092), 格納 (4758), vblf (4692), ッセ (3964), メッ (3944), entirerow (3895), myrng (3724), 処理 (3531), セー (3501), 2017 (3491), 終行 (3219), 最終 (3060), 削除 (2939)
- 『配列に格納したデータの重複をなくしたい』（ちゃんぷる）
お世話になっております。 各行ごとに、文字検索をして該当したセルがあるA列の項目名を 配列msgに格納しメッセージボックスに表示させています。 この時、同じ行に文字検索に該当したセルがループのたびに見つかると 配列msgに同じ項目名が追記されてしまいます。 例 3行目に「□」という文字列が別々のせるから3つ見つかった場合 配列msgにA列の項目名が なすび なすび なすび と表示される。 質問は 同じ行から検索文字列がいくつ見つかってもA列の行項目は一つであるため 「なすび」 一つだけ格納したい。 以下が現在のコードです。 Dim a As Range '検索セル Dim i As Long '行 Dim r As String '挿入先セル番地 Dim msg As String '2行目〜最終行までを処理 For i = 2 To Range("A" & Rows.Count).End(xlUp).Row ' i行目の列範囲(B:AF)に値aのあるセルに対し For Each a In Range("B" & i & ":AF" & i) '指定文字を含む場合(Like) If a.Value Like "*□*" Then '一致セルaの下セル番地を取得しrに格納 r = a.Address Range(r).Font.ColorIndex = 3 '文字の着色 'メッセージボックス用データを追記格納しておく msg = msg & vbNewLine & Range("A" & (a.Row)).Value End If 'なければa範囲までを処理 Next a Next i 'メッセージボックスへ配列格納データを表示 If msg <> "" Then MsgBox "以下の未入力(赤)があります。" & vbNewLine & msg Else End If ＜ 使用 Excel:Excel2010、使用 OS:Windows7 ＞ ---- >ちゃんぷる さん >質問は >同じ行から検索文字列がいくつ見つかってもA列の行項目は一つであるため >「なすび」 一つだけ格納したい。 ちゃんぷるさんのコードを元に、やりたいことができるように、コードを組み直しました。 ★印をつけた行に、着目してください。 iが変化するたびに、flagをリセット(flag = False)しています。 Sub Sample1() Dim a As Range, i As Long, msg As String Dim flag As Boolean '★ For i = 2 To Range("A" & Rows.Count).End(xlUp).Row flag = False '★初期値（iが変化するたびにリセット） For Each a In Range("B" & i & ":AF" & i) If a.Value Like "*□*" Then flag = True '★指定文字を含む場合はTrue a.Font.ColorIndex = 3 End If Next a If flag = True Then msg = msg & vbNewLine & Range("A" & i).Value '★ Next i If msg <> "" Then MsgBox "以下の未入力(赤)があります。" & vbNewLine & msg End Sub （マリオ） 2017/02/20(月) 04:32 ---- 次のコードでも、やりたいことができます。Dictionaryを使う方法です。 ★印をつけた行に、着目してください。 Sub Sample2() Dim sh As Worksheet, fr As Long, myRng As Range, c As Range Dim Dic As Object, msg As String Dim buf As Variant'★Variant型 Set sh = ThisWorkbook.ActiveSheet 'Set sh = ThisWorkbook.Sheets("テスト")'★アクティブでないシートの場合はこちら fr = sh.Cells(Rows.Count, "A").End(xlUp).Row Set myRng = sh.Range(sh.Cells(2, "B"), sh.Cells(fr, "AF")) Set Dic = CreateObject("Scripting.Dictionary")'★ For Each c In myRng If c Like "*□*" Then c.Font.ColorIndex = 3 buf = c.Row'★行番号 Select Case Dic.Exists(buf)'★ Case True '★行番号が、辞書に登録されていたら、何もしない Case False'★されてなければ、次の処理を行う Dic.Add buf, buf '★辞書を書き換える処理 msg = msg & vbNewLine & Range("A" & c.Row).Value'★msg書き換えの処理 End Select End If Next c If msg <> "" Then MsgBox "以下の未入力(赤)があります。" & vbCr & msg Set sh = Nothing: Set myRng = Nothing: Set Dic = Nothing End Sub （マリオ） 2017/02/20(月) 04:32 ---- Dictionaryを使うのであれば以下で充分だと思います。 領域が大きいので、重複文字列の数によっては Findメソッドを使ったほうがいいかもしれませんが 現在の、セルをすべてなめる方式にしてあります。 ところで、領域記述、気になるところがあります。 r = a.Address Range(r).Font.ColorIndex = 3 '文字の着色 アドレス経由せず、直接 a.Font.ColorIndex = 3 '文字の着色 でOKです。 また、Range("A" & (a.Row)) a.Row を かっこで囲む必要はありません。Range("A" & a.Row) でOKです。 Sub Test() Dim a As Range '検索セル Dim msg As Object Set msg = CreateObject("Scripting.Dictionary") '2行目〜最終行までを処理 With Range("A2", Range("A" & Rows.Count).End(xlUp)).Columns("B:AF") .Font.ColorIndex = xlAutomatic For Each a In .Cells '指定文字を含む場合(Like) If a.Value Like "*□*" Then a.Font.Color = vbRed msg(a.EntireRow.Range("A1").Value) = True '★ End If Next a End With 'メッセージボックスへ配列格納データを表示 If msg.Count > 0 Then MsgBox "以下の未入力(赤)があります。" & vbNewLine & Join(msg.keys, vbLf) '★ End Sub （ β） 2017/02/20(月) 06:54 ---- Findを使った例です。 Sub Test2() Dim a As Range '検索セル Dim f As Range Dim msg As Object Set msg = CreateObject("Scripting.Dictionary") '2行目〜最終行までを処理 With Range("A2", Range("A" & Rows.Count).End(xlUp)).Columns("B:AF") .Font.ColorIndex = xlAutomatic Set a = .Find(What:="□", LookAt:=xlPart) If Not a Is Nothing Then Set f = a Do a.Font.Color = vbRed msg(a.EntireRow.Range("A1").Value) = True '★ Set a = .FindNext(a) Loop While a.Address <> f.Address End If End With 'メッセージボックスへ配列格納データを表示 If msg.Count > 0 Then MsgBox "以下の未入力(赤)があります。" & vbNewLine & Join(msg.keys, vbLf) '★ End Sub （ β） 2017/02/20(月) 07:43 ---- マリオさん βさん いつも、アドバイスありがとうございます。 いづれも、動作確認できました。 早速とりいれて、作業を勧めたいと思います。 解決です(^^) （ちゃんぷる） 2017/02/20(月) 08:35 ---- >ちゃんぷる さん >質問は >★同じ行から検索文字列がいくつ見つかってもA列の行項目は一つであるため >「なすび」 一つだけ格納したい。 下記の表のように、「A2」,「A5」に「なすび」が入っている場合は、 どう処理したいのでしょうか?私のコードとβさんのコードで、 結果が異なります。A列に重複は、絶対にないと言えますか? |[A] |[B]|[C] [2]|なすび|□ |□ [3]|りんご|□ |□ [4]|バナナ|□ |□ [5]|なすび|□ |□ ************************************************************************* 私の例（Sample1またはSample2）では、 MsgBoxで、 ■■■■■■■■■■■■■■■ 以下の未入力(赤)があります。 なすび りんご バナナ なすび ■■■■■■■■■■■■■■■ と表示され、2つめの「なすび」も表示 βさんの例（TestまたはTest2）では、 MsgBoxで、 ■■■■■■■■■■■■■■■ 以下の未入力(赤)があります。 なすび りんご バナナ ■■■■■■■■■■■■■■■ と表示されます。 ************************************************* βさんのコードで、Forループ直後に、 「.Font.ColorIndex = xlAutomatic」がありますが、 この処理、私のコードではしていません。必要な処理ですね。 （マリオ） 2017/02/20(月) 17:07 ---- まぁ、要件次第でしょうけど、仮に、登場した行番号も必須ということであれば キーに行番号も加えた形にすればいいでしょうね。 msg(a.EntireRow.Range("A1").Value) = True '★ これを msg(a.EntireRow.Range("A1").Value & ":" & a.row & "行目") = True '★ といった感じで。 私のコードでは、A列の項目名のみ、各行の状態はセルが赤くなっているのでわかるでしょ というものです。 （ β） 2017/02/20(月) 19:13 ---- βさん 返信ありがとうございます。 A列の重複値は予め下記の処理により削除しています。 A列（個人名）に重複する値があった場合 →そのデータ領域（B:AF）を統合処理（個人毎にデータの一本化） →統合処理した行以外の重複個人名は削除 Sub 請求Data重複統合処理() Dim i As Long '行範囲（A列で取得） Dim j As Long '列範囲（1行目で取得） Dim k As Long '重複セル（2番目以降の重複セル） Dim L As Long '重複セル（1番目の重複セル） '-----A列重複行のデータ範囲に値があれば、そのセルを重複先頭行の同じセル位置に切り貼り-------- For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 '2行目〜最終行を処理（A列最終行から取得） '行のデータ範囲をjに格納 For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column + 1 '2行目〜最終行を処理（A列最終行から取得） 'A列最終行から上に順番にチェックし重複セルをkに格納 For k = Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1 '値があれば、kセルj範囲に値があるか確認し If Cells(k, j) <> "" And WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(k, 1)), Cells(k, 1)) > 1 Then '値があればそのセルをLに格納 L = WorksheetFunction.Match(Cells(k, 1), Columns(1), False) '---重複項目セルの値に以下処理--- 'A列重複セルフォント着色 Cells(L, 1).Font.ColorIndex = 3 Cells(k, 1).Font.ColorIndex = 3 '切り貼り（1番目重複行Lに2番目重複行kの値を切り貼り）重複値上書き Cells(k, j).Cut Destination:=Cells(L, j) End If Next k Next j Next i '-----残骸処理1:iの処理で重複行データ範囲に値がないA列の不要行項目を削除------------------ For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 'データ範囲に値がない場合 If WorksheetFunction.CountA(Rows(i)) = 1 Then 'その項目行は削除 Rows(i).ClearContents End If Next i '-----残骸処理2:A列の空白行を削除--------------------------------------------------------- Dim last_Row, h As Long last_Row = Cells(Rows.Count, 1).End(xlUp).Row For h = last_Row To 1 Step -1 If WorksheetFunction.CountA(Rows(h)) = 0 Then Rows(h).Delete End If Next h End Sub （ちゃんぷる） 2017/02/20(月) 23:01 ---- メッセージボックスで、新たな問題が発生しまいた。 メッセージボックスに読み込む値の有無により表示させる値を変えたいと思います。 下記の部分で 1「msg」と「msg2」両方に値があれば・・MsgBoxで、両方とも表示 2「msg」と「msg2」どちらか片方に値があれば・・MsgBoxで、片方を表示 3 取り込む値が両方ともなければ、MsgBox "正常終了" といった分岐をしたいと考えておりますが、アドバイスの程よろしくお願いします。 If msg2 & msg <> "" Then '両方 MsgBox "エラー1（A列の領域）" & vbNewLine & msg2 _ "エラー2（データ領域）" & vbNewLine & msg Else MsgBox "正常終了" '何もなし End If Sub Data最終エラーチェック() Dim a As Range '検索セル Dim i As Long '行 Dim r As String '挿入先セル番地 Dim msg As String Dim flag As Boolean 'メッセージボックスへの格納（重複はリセット） '-----エラー処理（データ領域のチェック）---------------------------------------------- '2行目〜最終行までを処理 For i = 2 To Range("A" & Rows.Count).End(xlUp).Row flag = False '★初期値（iが変化するたびにリセット） ' i行目の列範囲(B:AF)に値aのあるセルに対し For Each a In Range("B" & i & ":AF" & i) '指定文字を含む場合(Like) If a.Value Like "*□*" Then flag = True '★指定文字を含む場合はTrue '一致セルaの下セル番地を取得しrに格納 a.Font.ColorIndex = 3 '文字の着色 End If 'なければa範囲までを処理 Next a If flag = True Then msg = msg & vbNewLine & Range("A" & i).Value '★ Next i '-----エラー処理（A列のチェック）---------------------------------------------- Dim a2 As Range '検索セル Dim i2 As Integer '行番号 Dim r2 As String '着色文字のあるセル Dim msg2 As String '2行目〜最終行までを処理 i2 = Range("A" & Rows.Count).End(xlUp).Row ' 行範囲(A:A最終行)に値aのあるセルに対し For Each a2 In Range("A2:A" & i2) If a2.Font.ColorIndex = 3 Then msg2 = msg2 & vbNewLine & Range("A" & a2.Row).Value End If Next a2 If msg2 & msg <> "" Then '両方 MsgBox "エラー1（A列の領域）" & vbNewLine & msg2 _ "エラー2（データ領域）" & vbNewLine & msg Else MsgBox "正常終了" '何もなし End If End Sub （ちゃんぷる） 2017/02/20(月) 23:14 ---- >A列の重複値は予め下記の処理により削除しています であれば、私がアップした Test あるいは Test2 でいいわけですね。 ただ、アップされた、重複削除のためのコード、?????ですね。 エクセル標準機能の 重複の削除（VBAコードとしては RemoveDuplicates) 1行ですむ話ではないですか? ところで、（ちゃんぷる） 2017/02/20(月) 23:14 コードを読んでも何をしたいかがわかりません。 前半でデータ領域に該当のセルがあれば、その行のA列に色を付けますよね? で、後半で、A列に色がついている行をピックアップしてますね? それらを比較してなにをしたいのですか? というか、 ・どんな場合に1行表示で、どんな場合に2行表示なんですか? (正常時のメッセージは理解できます） ついでに If msg2 & msg <> "" Then これは何を判定してます? Msg も msg2 も 値がある（"" ではない）ということを判定しようとしている? もしそうであれば、このコードは間違いです。 このコードは msg と msg2 を連結した文字列が "" ではない という判定です。 ですから、いずれかに値があれば ということになっています。（それでいいならいいのですが） いずれにしても 後半がなぜ必要なのか、後半で何をしようとしているのかがわかりません。 （ β） 2017/02/20(月) 23:58 ---- >ちゃんぷる さん >A列の重複値は予め下記の処理により削除しています。 【Sub 請求Data重複統合処理()】 を見てみましたが、 まず、 ***************************************************************** For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 '2行目〜最終行を処理（A列最終行から取得） ■jとkのforループ処理 Next i ***************************************************************** のiのForループ内で、iは使用されていません。 無駄なForループになっています。ん〜。 _ _ _ βさんのコメントに、 >エクセル標準機能の 重複の削除（RemoveDuplicates) とありましたが、A列で重複が見つかった行を削除しただけなら、 【A列にて重複が見つかった行を削除2】のコードで可能です。 ******* ↓ここから *********************************************** 'RemoveDuplicatesを使った例 Sub A列にて重複が見つかった行を削除2() Dim sh As Worksheet, fr As Long Set sh = ThisWorkbook.Sheets("Sheet1") fr = sh.Cells(Rows.Count, "A").End(xlUp).Row sh.Range(sh.Cells(2, "A"), sh.Cells(fr, Columns.Count)).RemoveDuplicates _ Columns:=1, Header:=xlNo Set sh = Nothing End Sub ******* ↑ここまで *********************************************** _ _ _ おそらく、A列の重複行を削除したいだけでなく、 A列の何処を重複させてしまったしまったのか、自己確認したいので、 重複削除する前に色付けして、どの場所なのか目で見て確認した後に、 重複している行を削除したいってことだろうと思います。 違いますか? 【A列にて重複が見つかった行を削除1】のコードを試してみてください。 ******* ↓ここから *********************************************** 'Dictionaryを使った例 Sub A列にて重複が見つかった行を削除1() Dim sh As Worksheet, a As Range, Dic As Object, Astr As Variant, myRng As Range Set Dic = CreateObject("Scripting.Dictionary") Set sh = ThisWorkbook.Sheets("Sheet1") '★シート名は、Sheet1 sh.Range("A1", sh.UsedRange).Offset(1).Interior.Pattern = xlNone '★塗りつぶしなし For Each a In sh.Range("A2", Range("A" & Rows.Count).End(xlUp)) Astr = a.Value Select Case Dic.Exists(Astr) Case True 'A列の文字列が、すでに辞書に登録されているなら、行範囲をmyRngに記録 If myRng Is Nothing Then Set myRng = a.EntireRow '行範囲を記録（はじめての記録） Else Set myRng = Union(myRng, a.EntireRow) '追加で、行範囲を記録 End If Case False Dic.Add Astr, Astr 'A列の文字列が、辞書に登録されてなければ辞書に登録 End Select Next a Dim msg As String, title As String, rc As Integer If myRng Is Nothing Then MsgBox "A列の文字列に、重複はありません" Else title = " 「はい」 「いいえ」 を選択してください" msg = "「はい」 : 重複行を削除" & vbCr & _ "「いいえ」: 重複行をピンク色で色塗り" rc = MsgBox(msg, vbYesNo, title) If rc = vbYes Then myRng.Delete '行範囲が記録されているなら、その行範囲を削除 Else myRng.Interior.Color = RGB(255, 204, 204) '削除対象の行をピンク色で塗りつぶす End If End If Set sh = Nothing: Set Dic = Nothing End Sub ******* ↑ここまで *********************************************** _ _ _ また、【Sub Data最終エラーチェック()】は、 次のように書けば足りるような気がしますが…。 ちゃんぷるさんの【Sub Data最終エラーチェック()】ですが、 βさんと同じく、 >後半がなぜ必要なのか、後半で何をしようとしているのかがわかりません。 ******* ↓ここから *********************************************** Sub 未入力チェック() Dim sh As Worksheet, myRng As Range Set sh = ThisWorkbook.Sheets("Sheet1") '★シート名は、Sheet1 sh.Range("A1", sh.UsedRange).Offset(1).Font.ColorIndex = xlAutomatic '★文字色を「自動」にする Dim a As Range, i As Long, msg As String Dim flag As Boolean For i = 2 To Range("A" & Rows.Count).End(xlUp).Row flag = False '★初期値（iが変化するたびにリセット） For Each a In Range("B" & i & ":AF" & i) If a.Value Like "*□*" Then flag = True '★指定文字を含む場合はTrue a.Font.ColorIndex = 3 End If Next a If flag = True Then msg = msg & vbNewLine & i & "行目 : " & Range("A" & i).Value '★ Next i If msg <> "" Then MsgBox "以下の未入力(赤)があります。" & vbNewLine & msg Else MsgBox "未入力はありません(B〜AF列)" End If End Sub ******* ↑ここまで *********************************************** （マリオ） 2017/02/21(火) 05:00 ---- 重複の削除はさておき、 >メッセージボックスで、新たな問題が発生しまいた。 発生した新たな問題というのはどんなことでしょう。 再掲された Data最終エラーチェック で何か不都合があったのですか? もしかしたら 再掲されたコードでやりたかったことは、βがアップした TestやTest2 の msg(a.EntireRow.Range("A1").Value) = True '★ を msg(a.EntireRow.Range("A1").Value & ":" & a.row & "行目") = True '★ に変更し、 If msg.Count > 0 Then MsgBox "以下の未入力(赤)があります。" & vbNewLine & Join(msg.keys, vbLf) '★ これを If msg.Count > 0 Then MsgBox "以下の未入力(赤)があります。" & vbNewLine & Join(msg.keys, vbLf) '★ Else MsgBox "正常終了" End If にすれば、事足りるのではないですか? あえて A列データを列挙してから、その行番号情報をその下に列挙したいなら たとえば Test2をベースにすると、以下ですけど、メッセージ、必ずしも見やすいとは言えませんが? Sub Test3() Dim a As Range '検索セル Dim f As Range Dim msg As Object Set msg = CreateObject("Scripting.Dictionary") '2行目〜最終行までを処理 With Range("A2", Range("A" & Rows.Count).End(xlUp)).Columns("B:AF") .Font.ColorIndex = xlAutomatic Set a = .Find(What:="□", LookAt:=xlPart) If Not a Is Nothing Then Set f = a Do a.Font.Color = vbRed msg(a.EntireRow.Range("A1").Value) = a.Row & "行目" '★ Set a = .FindNext(a) Loop While a.Address <> f.Address End If End With 'メッセージボックスへ配列格納データを表示 If msg.Count > 0 Then MsgBox "エラー1 A列領域" & vbLf & Join(msg.keys, vbLf) & _ vbLf & "エラー2 データ領域" & vbLf & Join(msg.items, vbLf) '★ Else MsgBox "正常終了" End If End Sub （ β） 2017/02/21(火) 05:16 ---- 本題とは離れますが、文章を改行させる場合、vbNewLine は、あまり使いませんね。 結果はいずれも同じなんですが、改行コードには vbLf 、vbCr、vbCrLf、vbNewLine 等がありますね。 vbNewLine は vbCrLf と、全く同じ 2桁の x0D0A です。 Windows標準は vbCrLf、Mac が vbCr、Unix や Linux が vbLf。（最近のMacは変わっているかもしれませんが） ただ、WIndows配下でもエクセルではなぜか vbLf(セル内改行を行うと、vbLfが挿入されます）が標準。 βは横着ものですので 改行はすべて vbLf にしていますが、Windowsアプリということを意識するなら vbCrLf としたほうがいいのかもしれませんね。 (ですから vbNewLine でもいいわけですが） （ β） 2017/02/21(火) 05:30 ---- あぁ、重複の削除処理に間違いがあったかどうかを確かめたかった? であれば、こんなことをする必要はない というか、こんなことをしてはいけません。 どうしなければいけないかというと、 ★間違いのない重複削除コードを書く。 マクロ処理をして、そのあと、その処理に間違い（コードのバグ）があったかどうかをチェックするというのは 開発フェーズではやることもありますが、本番として、やるのは、????? です。 ★ただし、内部統制という観点で IT業務統制の中に、プログラム処理が正しく実行されたかどうかを 別プログラムで検証することが可能となっている状況を合格基準としていますので もし、ちゃんぷるさんが、その目的で、あえて、チェックしているのなら別ですが。 でも、それなら、両方の状態が一致しているかどうかを表示すべきであり 単なる羅列は意味がないですね。 （ β） 2017/02/21(火) 05:40 ---- βさん 夜遅くから早朝と・・・寝られていますか? 頭が下がります。 返信をいま確認しております。 仕事の合間になりますが、自身のコードをもう一度振り返りたいと思います。 お時間ください。 （ちゃんぷる） 2017/02/21(火) 08:53 ---- ＞自身のコードをもう一度振り返りたいと思います。 手作業でするならこんな感じでできませんか? 1）A列のセルの順に見て、作業を繰り返す。 2）n個目のセルの値が上から見てA列の何行目に出てくるか検索（Match関数） 3）もし、検索で見つかった行番号がn個目のセルと同じなら何もしない（=先頭データ） 4）上記の条件に合致しなければ、B列以降を切取り、検索して見つかった行の末尾以降に貼付 5）データが無くなるまで繰り返し 6）A列の値が重複している行を削除 この手順をマクロの記録機能でVBAのコードにしてもらったものを、整理したら、 作業の自動化ができませんかね。。。。? βさんの言われるように、マクロでちゃんと仕事が出来たかチェックする作業は不要になるように、 マクロを作らなければ、マクロを作る意味がないかなぁと思います。 （まっつわん） 2017/02/21(火) 11:15 ---- ↑の日本語をVBAに翻訳してみました。 Sub test001() Dim rngTable As Range '表全体のセル範囲 Dim rngKey As Range '分別のキーとなる列（セル範囲） Dim rngData As Range '移動するデータ範囲 Dim c As Range '順に見て行く各セル Dim m As Variant '上から見て最初に見つかった行番号 Set rngTable = ActiveSheet.Range("A1").CurrentRegion Set rngKey = rngTable.Resize(, 1) Set rngData = rngTable.Resize(, rngTable.Columns.Count - 1).Offset(, 1) For Each c In rngKey.Cells m = WorksheetFunction.Match(c.Value, rngKey, 0) If m < c.Row Then rngData.Rows(c.Row).Cut rngKey(m, 1).End(xlToRight).Offset(, 1) Next rngTable.CurrentRegion.RemoveDuplicates Columns:=1 End Sub （まっつわん） 2017/02/21(火) 11:48 ---- 皆さますみません 情報不足の中、アドバイスをいただきまして逃げ出したいくらい恐縮しております。 アドバイスいただいたものを参考に、予定管理から請求処理のシートを作成しており。 全体の処理についてもアドバイスのお陰で、業務に耐えるレベルに達し完成しました。 ※ただ、ご指摘があった通り、不要なコードや無駄なコードが多々ありますが・・・・ アドバイスを参考に見直したいと思います。 さて、 質問についてですが、最終仕上げ（欲）エラーチェックの部分を改善したいとおもいました。 質問内容が多岐にわたっていましたので、まずは下記の書き込み部分についてご説明を させていただきたいと思います(^_^;) （ちゃんぷる） 2017/02/20(月) 23:14 分・・・の質問を改めて整理整理しました。 質問は 着色セルがある領域「（A列セル）と（B:AFセル」）によって表示を分岐したいです。 （1）A列に 赤文字 セルがある場合（元々重複者） ※これは別マクロ処理で、重複者のデータを統合し重複行削除した際に「この人は元々重複者」 であることが分かるように予め赤文字着色されてあります。 （2）B:AFデータ領域に 赤文字 セルがある場合（入力ミス者） ※これはアップしたマクロ処理で、データ領域内に「□（入力ミスの印）」文字があれば 赤文字着色しています。そしてメッセージ表示 （3）赤文字が上記にない場合 ですので、メッセージボックスに表示させる（1）と（2）は別の用件として捉えて ・元々重複者がいれば、A列の 個人名を表示し注意を促す（1） ・データ領域に入力ミスがあれば、その行のA列の 個人名を表示し注意を促す（2） ・（1）と（2）両方ともあれば、1つのメッセージボックスで、各々読み込み注意を促す としたいと考えていました。 メッセージ表示例 ・元々重複者のみの場合・・・・重複者はmsg2です ・入力ミス者のみの場合・・・入力ミスはmsgです ・両方いる場合・・・「重複者はmsg2です」「入力ミスはmsgです」 ・何もない場合・・・正常終了しました。 例 ※1行目は項目行 _[A][B][C][D][E]・・・ 1 2東,あ,あ,あ,あ,あ,, 3西,あ,あ,あ,あ,あ,,←赤文字（A3）msg2 = msg2 & vbNewLine & Range("A" & a2.Row).Value 4南,あ,あ,あ,あ,あ,, 5北,あ,あ,□,あ,あ,,←赤文字（D5）If flag = True Then msg = msg & vbNewLine & Range("A" & i).Value ・ ・ ・ 上記ではmsg2ヒット者が1名、msgヒット者が1名いるので メッセージ表示は 重複者は「西」です。入力ミスは「北」です。 とまとめて表示させたいと考えています。 ※1行目は項目行 _[A][B][C][D][E]・・・ 1 2東,あ,あ,あ,あ,あ,, 3西,あ,あ,あ,あ,あ,, 4南,あ,あ,あ,あ,あ,, 5北,あ,あ,□,あ,あ,,←赤文字（D5）If flag = True Then msg = msg & vbNewLine & Range("A" & i).Value ・ ・ ・ ※A列に赤文字なし 上記ではmsg2ヒット者が0名、msgヒット者が1名いるので メッセージ表示は 入力ミスは「北」です。 と該当部分のみ表示させたいと考えています。 なんか、説明がうまくできず、本当にみなさんすみません、表を貼り付けたいくらいです・・・ （ちゃんぷる） 2017/02/21(火) 14:51 ---- ＞表を貼り付けたいくらいです・・・ ならば、貼り付けてみては?（どうなるか試してみるのは悪くないと思いますが。。。） シート上のイメージを提示するのはいいことだと思います。 （ここのサイトは色は自由に使えないのかなぁ。。。） （まっつわん） 2017/02/21(火) 15:03 ---- なるほど。了解。じゃぁ、こんなことですかね。(15:24 差し替え） Sub Test4() Dim a As Range '検索セル Dim f As Range Dim dic As Object Dim msg As String Set dic = CreateObject("Scripting.Dictionary") '2行目〜最終行までを処理 With Range("A2", Range("A" & Rows.Count).End(xlUp)) 'A列チェック For Each a In .Cells If a.Interior.Color = vbRed Then dic(a) = True Next If dic.Count > 0 Then msg = "重複者は以下の通りです" & vbLf & Join(dic.keys, vbLf) dic.RemoveAll 'データ領域チェック With .Columns("B:AF") .Font.ColorIndex = xlAutomatic Set a = .Find(What:="□", LookAt:=xlPart) If Not a Is Nothing Then Set f = a Do a.Font.Color = vbRed dic(a.EntireRow.Range("A1").Value) = True '★ Set a = .FindNext(a) Loop While a.Address <> f.Address End If End With End With If dic.Count > 0 Then msg = msg & IIf(msg = "", "", vbLf) & "入力ミスは以下です" & vbLf & Join(dic.keys, vbLf) If msg = "" Then MsgBox "正常終了" Else MsgBox msg End If End Sub （ β） 2017/02/21(火) 15:18 ---- >βさん >（1）A列に 赤文字 セルがある場合（元々重複者） とちゃんぷるさんがいってますので、Sub Test4()の If a.Interior.Color = vbRed Then dic(a) = True のとこは、 If a.Font.Color = vbRed Then dic(a) = True ですかね。 好みですが、vbRedのところを、RGB(255,0,0)としてもいいですね。 （マリオ） 2017/02/21(火) 16:24 ---- あぁ、A列の赤も文字色でしたか! うっかりものですね。 >vbRedのところを、RGB(255,0,0) もちろん、いいですね。 直接 255 という色番号を与えてもいいですし、カラーインデックスで 3 を与えてもいいわけですが。 好みというより、vbRed だと、誰が見ても 赤なんだなと、わかりやすいので、VBAのColorConstantsクラスで 定義されているものについては、私の場合は、必ず 色定数を使います。 （これに限らず、マジックナンバーを使うのは極力避けています） 8色しか定義されていないのが玉に瑕ですけど、昨今のバージョンなら エクセルの xlRgbColorクラスの定数、 これは 144個定義されていますので、それらを使う場合もあります。 （144個といっても、灰色関係が Grey と Gray のいずれでも定義されて言いますので 144種類 ということではないですが） rgbTomato (トマト色）なんて、ほっこりするような定数名もあります。 rgbRed も vbRed と同じ色番号がアサインされてますね。 中には rgbGreen 、これは vbGreen より、ちょっとくらい緑の色番号になっているものもありますが。 （ β） 2017/02/21(火) 16:59 ---- 皆さまのご協力に感謝感謝ですm(_ _)m エクセル表を掲示板へのコピー ・試しにやってみました。→プレビューで正しく表示されましたので今後、活用してみます。 βさんのコード確認しました。 イメージ通りに動きました。やっとスッキリしました。 ありがとうございます。 'A列チェック For Each a In .Cells If a.Font.Color = vbRed Then dic(a) = True 皆さん、様々なアドバイスに感謝します。 解決しました(^^) （ちゃんぷる） 2017/02/21(火) 18:29... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201702/20170220002841.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：