VBAについて教えて教えて頂けますと幸いです。 普段の業務でE5以下の内容で重複があったら塗りつぶして重複を確認、という作業をするために
VBAについて教えて教えて頂けますと幸いです。 普段の業務でE5以下の内容で重複があったら塗りつぶして重複を確認、という作業をするために 現在は有識者の方が公開していたコードをもとに以下の様に少し変更させていただいてありがたく使用しておりますが、 上司に追加機能を求められ、私はマクロに詳しくないので困っております。 求められている追加機能といたしまして、 ・追加で重複チェック範囲の中で末尾から3文字目までにA以外の文字が入っているセルは文字の色を変更する。※ただし内容にFTのもじが入っているものは除く。 ・現在使用させていただいているものは重複をなくした後に再度実行しても塗りつぶされた色はそのままなので、再度実行したら元の塗りつぶしなしの黒字に戻ってほしい。 上記の2点です。 下記現在使用しているコードです。 Sub 重複チェック() '(1) マクロ実行中、描画オフ、カーソル描画オフ Application.ScreenUpdating = False Application.Cursor = xlWait ' '+-----------------------------------------------------------------+ '+ 変数宣言 + '+-----------------------------------------------------------------+ '配列作成用 Dim 処理行 As Long Dim 比較文字列() As String ' '配列比較用 Dim 配列A処理行 As Long Dim 配列B処理行 As Long '+-----------------------------------------------------------------+ '+ 初期設定 + '+-----------------------------------------------------------------+ 重複チェック列 = 5 重複チェック開始行 = 5 重複チェック終了行 = 1000 結果出力列 = 5 シート名 = "テスト" '(2) 配列 作成 '初期処理 処理行 = 重複チェック開始行 Do Until 処理行 > 重複チェック終了行 ReDim Preserve 比較文字列(処理行) 比較文字列(処理行) = Worksheets(シート名).Cells(処理行, 重複チェック列) 処理行 = 処理行 + 1 Loop '(3) 重複確認 配列A処理行 = 重複チェック開始行 Do Until 配列A処理行 > 重複チェック終了行 配列B処理行 = 配列A処理行 + 1 Do Until 配列B処理行 > 重複チェック終了行 If 比較文字列(配列A処理行) <> "" Then If 比較文字列(配列A処理行) = 比較文字列(配列B処理行) Then Worksheets(シート名).Cells(配列A処理行, 結果出力列).Interior.ColorIndex = 22 Worksheets(シート名).Cells(配列B処理行, 結果出力列).Interior.ColorIndex = 22 End If End If 配列B処理行 = 配列B処理行 + 1 Loop 配列A処理行 = 配列A処理行 + 1 Loop '描画オン Application.ScreenUpdating = True Application.Cursor = xlDefault End Sub もしお分かりになられる方がいらっしゃいましたらお知恵を貸していただけないでしょうか。何卒宜しくお願い致します。
Visual Basic | Excel・148閲覧・50
ベストアンサー
再回答します。 【返信で貴方が変更提示した条件】 ・重複のあるものはセルに色 ・文字の最後3文字の中に、0,1,2,3,4,5,6,7,8,9,A,_,- でない文字があったら文字を青、ただし文字の中に「FT」があれば文字の色は変えない。 Sub test2() Dim rmax As Long, r As Long Dim rng As Range Dim buf As Variant Dim i As Integer Application.ScreenUpdating = False With Worksheets("テスト") rmax = .Cells(Rows.Count, "E").End(xlUp).row Set rng = .Range("E5:E" & rmax) rng.Interior.ColorIndex = xlNone rng.Font.ColorIndex = 1 For r = 5 To rmax buf = .Cells(r, 5).value If WorksheetFunction.CountIf(rng, buf) > 1 Then .Cells(r, 5).Interior.ColorIndex = 22 End If If InStr(buf, "FT") = 0 Then For i = Len(buf) - 2 To Len(buf) If Not Mid(buf, i, 1) Like "[0-9]" And Mid(buf, i, 1) <> "A" _ And Mid(buf, i, 1) <> "_" And Mid(buf, i, 1) <> "-" Then .Cells(r, 5).Font.ColorIndex = 5 Exit For End If Next i End If Next r End With Application.ScreenUpdating = True End Sub
1人がナイス！しています
質問者からのお礼コメント
説明不足のために何度も何度もご迷惑をお掛けしまして申し訳ございませんでした。 そして本当に感謝申し上げます。 求めていた動作が完璧に行えました！ 心よりお礼申し上げます。
お礼日時：1/21 20:53
