[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セル内の文字を比較し、違う文字のみ色分けする』（すもも）
Excel2000・Windows2000
いつも大変お世話になっております。
次のような表がある場合、B列のセル内の文字をA列のセル内の文字と比較して、
C列に、その違う部分だけ（カギカッコ｢｣でくくった部分）を
赤など違う色で表示さすことはできるでしょうか？
この場合、下記のように文字数や間違っている個所はバラバラで、
誤字のほか脱字や衍字も考えられます。
A B C
1 アルキメデス アルキメンデス アルキメ｢ン｣デス
2 ブッシュ プッシュ ｢プ｣ッシュ
3 ロナウジーニョ ロナウド ロナウ｢ド｣
4 マッカーサー マッサーカー マッ｢サ｣ー｢カ｣ー
5 ロドリゲス オドリダス ｢オ｣ドリ｢ダ｣ス
こういった場合、何かよい関数・マクロなどあるのでしょうか？
それともエクセルではムリなんでしょうか？
少々わかりにくい説明かとは思いますが、ご教授よろしくお願いいたします。
こんなんでよろしいんでっしゃろか？
アルキメデス、アルキメンデスなどのデータは横並び（列がひっついてる）として
作ってあります。
抽出したいセルをアクティブにしてsumomoを実行してみてくらはい。
範囲はマウスでなぞっても、書き込んでもOKです。
上手いこといったら儲けモン。（笑
（弥太郎）
'------------------------------------------
Option Explicit
'--------------------------------------------
Sub sumomo()
Dim i As Long
Dim n As Integer, t As Integer, j As Integer, f As Integer
Dim adrs As String
Dim clr()
Dim tbl As Range
adrs = ActiveCell.Address(0, 0)
Set tbl = Application.InputBox("範囲を指定して下さい", Type:=8)
With tbl
For i = 1 To .Rows.Count
Range(adrs).Cells(i, 1).Font.ColorIndex = xlAutomatic
If .Cells(i, 1) = .Cells(i, 2) Then
Range(adrs) = .Cells(i, 1)
Else
f = 1
t = 1
For n = 1 To Len(.Cells(i, 2))
If Mid(.Cells(i, 1), n, 1) = Mid(.Cells(i, 2), t, 1) Then
Range(adrs).Cells(i, 1) = Range(adrs).Cells(i, 1) & Mid(.Cells(i, 2), t, 1)
Else
ReDim Preserve clr(f)
clr(f) = t
Range(adrs).Cells(i, 1) = Range(adrs).Cells(i, 1) & Mid(.Cells(i, 2), t, 1)
f = f + 1
If Len(.Cells(i, 1)) < Len(.Cells(i, 2)) Then
n = n - 1
End If
End If
t = t + 1
If t > Len(.Cells(i, 2)) Then Exit For
Next n
For j = 1 To UBound(clr)
Range(adrs).Cells(i, 1).Characters(start:=clr(j), Length:=1).Font.ColorIndex = 3
Next j
End If
Next i
End With
End Sub
弥太郎さん、力技ですね！ 私も挑戦していたのですが、B列の文字数のほうが少ない場合、 例：「アルメデス」、「ロナジーニョ」等 の処理を考えていましたら、行き詰まりました。(seiya)
seiyaはん、おおきに〜（笑 あんさんにお褒めの言葉を貰うとなにやら嬉しゅうなってきますワ。 心なしか鼻が高うなってきましたで・・・（笑 （弥太郎）
弥太郎さん、seiyaさん、お忙しい中ほんとにどうもありがとうございますっ！！！
とはいっても、実は私マクロって初めてなんです。。。
これを機会に勉強したいと思います。
そこであつかましいとは思いますが、
データが横並びでない（列がひっついていない）2つの列を
比較するのにはどうしたらいいのでしょうか？
また、比較して違いがなかったとしても、
そのB列の文字をそのままC列に表示させることはできるのでしょうか？
お願いばかりで申し訳ないのですが、よろしくお願いします。
（すもも）
あっ、後出しや！（笑
ほならこれでどうでっか？
範囲を指定する時は飛んどる列もひっくるめて指定しておくんなはれや。
例えばアルキメデスがA列で、アルキメンデスがE列やとするとA1:E100といった塩梅に
デスヨ。勿論マウスでなぞってもOKです。
これで後出しは無しにしまひょでぇ。（笑
（弥太郎）
'-------------------------
Option Explicit
'------------------------
Sub sumomo()
Dim i As Long
Dim n As Integer, t As Integer, j As Integer, f As Integer, col_count As Integer
Dim adrs As String
Dim clr()
Dim tbl As Range
adrs = ActiveCell.Address(0, 0)
Set tbl = Application.InputBox("範囲を指定して下さい", Type:=8)
col_count = tbl.Columns.Count
With tbl
For i = 1 To .Rows.Count
Range(adrs).Cells(i, 1).Font.ColorIndex = xlAutomatic
If .Cells(i, 1) = .Cells(i, col_count) Then
Range(adrs).Cells(i, 1) = .Cells(i, 1)
Else
f = 1
t = 1
For n = 1 To Len(.Cells(i, col_count))
If Mid(.Cells(i, 1), n, 1) = Mid(.Cells(i, col_count), t, 1) Then
Range(adrs).Cells(i, 1) = Range(adrs).Cells(i, 1) & Mid(.Cells(i, col_count), t, 1)
Else
ReDim Preserve clr(f)
clr(f) = t
Range(adrs).Cells(i, 1) = Range(adrs).Cells(i, 1) & Mid(.Cells(i, col_count), t, 1)
f = f + 1
If Len(.Cells(i, 1)) < Len(.Cells(i, col_count)) Then
n = n - 1
End If
End If
t = t + 1
If t > Len(.Cells(i, col_count)) Then Exit For
Next n
For j = 1 To UBound(clr)
Range(adrs).Cells(i, 1).Characters(start:=clr(j), Length:=1).Font.ColorIndex = 3
Next j
End If
Next i
End With
End Sub
おおおっ！！！すごいっ！！！
弥太郎さん、ほんとに感謝です。
どうもありがとうございました。
（すもも）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.