【ＶＢＡ】「同じ文字を含むセルがあるならば」とやりたい

質問

こんばんは。
エクセル2003を使用しています。

例えば
A1→「りんご」
A2→「りんご食べたい」

の場合、
「りんご」は2個以上あります
としたいのですがうまくいきません。

Sub 重複()
For 行 = 1 To Cells(65536, 1).End(xlUp).Row
If Cells.Find(what:=Range("a" & 行), LookAt:=xlPart) Is Nothing Then
Else 'あるならば
MsgBox Range("a" & 行) & "は2個以上あります"
End If
Next
End Sub

これだと取得セルもカウントされてしまうため、必ずMsgBoxが表示されてしまいます。
どうすれば取得セル意外にも取得セルを含むセルがあるかを調べられるのでしょうか？

そしてこれは
A1→「りんご」
A2→「りんご食べたい」
A3→「みかん」
A4→「みかんはオレンジ」
A5→「バナナ」
・
・
・
と続いており
最終的には
→「りんご食べたい」
→「みかんはオレンジ」
→「バナナ」
にしたいのです。

よろしくお願いします。

回答No.2

mt2008 · ベストアンサー

単に、同じ文字列を含むセルの数をカウントするなら
Application.WorksheetFunction.CountIf(Range("A:A"), Range("A" & 行) & "*")
で良いかと。

最終的には、同じ単語を含む文字列のうち、一番文字数の多い文字列だけを残したいと言うことでしょうか？
以下のマクロは、同じ単語を含む文字列のうち、一番文字数の多い文字列を探します。そして、同じ単語を含む文字列を、探し出した一番文字数の多い文字列で置換します。

例）
A1:りんご
A2:りんご飴
A3:りんご飴食べたい
↓
A1:りんご飴食べたい
A2:りんご飴食べたい
A3:りんご飴食べたい

後は、フィルタを掛けて重複を除けば望みの物になるかと。

Sub Sample()
　Application.ScreenUpdating = False
　nlast = Range("A1").End(xlDown).Row 'A列の最終行
　For 行 = 1 To nlast
　　'同じ文字列を含む行が無いかを確認
　　rtn = Application.WorksheetFunction.CountIf(Range("A:A"), Range("A" & 行) & "*")
　　'同じ文字列を含む行が有った場合
　　If rtn >= 2 Then
　　　'---ある文字列を含む最大文字数の行を調べる
　　　nMaxLen = 0
　　　nMaxRow = 0
　　　For 行2 = 1 To nlast
　　　　'+++ある文字列を含む文字列のうち最大文字数の行を調べる
　　　　rtn2 = 0
　　　　If InStr(Range("A" & 行2), Range("A" & 行)) > 0 Then
　　　　　rtn2 = Len(Range("A" & 行2))
　　　　End If
　　　　If rtn2 > nMaxLen Then
　　　　　nMaxLen = rtn2
　　　　　nMaxRow = 行2
　　　　End If
　　　Next 行2
　　　If 行 <> nMaxRow Then
　　　　'+++ 置換をかける
　　　　Columns("A:A").Replace What:=Range("A" & 行) & "*", Replacement:=Range("A" & nMaxRow)
　　　End If
　　End If
　Next 行
　Application.ScreenUpdating = True
End Sub

あくまでサンプルですので、変数の宣言やエラー処理は入れて居ません。

お礼

「最終的には、同じ単語を含む文字列のうち、一番文字数の多い文字列だけを残したいと言うことでしょうか？」
そうなんです！うまくいきました。
ありがとうございます。

回答No.5

Wendy02

こんにちは。

すでに解決しているような無視して構いませんが、

>A1→「りんご」
>A2→「りんご食べたい」
>A3→「みかん」
>A4→「みかんはオレンジ」
>A5→「バナナ」

「りんご・みかん・バナナ」　は、それぞれ検索キーワードではないでしょうか。
それが、被検索語と同じ場所にあるというのは、ちょっと変ですね。

すくなくとも、「りんご・みかん・バナナ」という検索キーワードを別にしないといけないように思いますが、それぞれのデータをすべて検索キーワードキーワードとしたら、検索してヒットすれば、後は、検索しないようにしてみました。

>最終的には
>→「りんご食べたい」
>→「みかんはオレンジ」
>→「バナナ」

実際のデータはどういうものかは分かりませんが、最終時には、重複を除去することだとは思います。
しかし、このようなデータでも、以下の場合は、３個のデータしか抽出しません。

------------------
りんご
りんご食べたい
りんご食べたい
りんご食べたくない
みかんはオレンジ
バナナ
りんご食べたい
りんご食べたい
りんご食べたくない
------------------

出力データ
バナナ
みかんはオレンジ
りんご食べたい

'-------------------------------------------------
　　Dim rng As Range
　　Dim k As Long
　　Dim Ar() As String
　　Const SH2 As String = "Sheet2" 　'書き出すシート
　　Const COL As Integer = 1　 'カウントの書き出す列、右ひとつとなり
Sub CheckDouble()
　　'昇順に並べられていることが条件です。
　　Dim buf As Integer
　　Dim i As Long
　　Dim j As Long
　　Dim flg As Boolean
　　Application.ScreenUpdating = False
　　Set rng = Range("A1", Range("A65536").End(xlUp))
　　rng.Offset(, COL).ClearContents
　　k = 1
　　With rng
　　　　For i = 1 To .Rows.Count
　　　　　　For j = i + 1 To .Rows.Count
　　　　　　　　If .Cells(i, 1).Value <> "" Then
　　　　　　　　　　buf = InStr(.Cells(j, 1).Value, .Cells(i, 1).Value)
　　　　　　　　　　If buf > 0 And .Cells(j, 1).Offset(, COL).Value = "" Then
　　　　　　　　　　　　.Cells(j, 1).Offset(, COL).Value = k
　　　　　　　　　　　　flg = True
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next j
　　　　　　If flg And .Cells(i, 1).Offset(, COL).Value = "" Then
　　　　　　　　.Cells(i, 1).Offset(, COL).Value = "o" & CStr(k)
　　　　　　　　k = k + 1
　　　　　　　　flg = False
　　　　　　ElseIf .Cells(i, 1).Offset(, COL).Value = "" Then
　　　　　　　　.Cells(i, 1).Offset(, COL).Value = k
　　　　　　　　k = k + 1
　　　　　　End If
　　　　Next i
　　End With
　　Call PickUp
　　Worksheets(SH2).Range("A1").EntireColumn.ClearContents
　　Worksheets(SH2).Range("A1").Resize(k).Value = Application.Transpose(Ar())
　　rng.Offset(, COL).ClearContents
　　Application.ScreenUpdating = True
　　Set rng = Nothing

　　If Ar(0) <> "" Then
　　　 MsgBox "データを " & Worksheets(SH2).Name & " に " & k - 1 & " 個出力しました。"
　　End If

End Sub
Sub PickUp()
Dim Ar2() As Long
Dim c As Variant
Dim i As Long
Dim buf As Variant
ReDim Ar(k - 1)
ReDim Ar2(k - 1)
i = 1
For Each c In rng.Offset(, COL)
　 If IsNumeric(c.Value) Then
　　　 buf = Application.Match(c.Value, Ar2(), 0)
　　　 If IsError(buf) Then
　　　　　Ar2(i - 1) = c.Value
　　　　　Ar(i - 1) = c.Offset(, -COL).Value
　　　　　i = i + 1
　　　　End If
　　End If
Next
End Sub

お礼

ありがとうございます。

回答No.4

imogasi

3,4やり方が有る。
標題どおりの質問ととる。２つ以上は考えない。
「１つでもあれば」渡海する。（標題とその後の内容が違ってないかな。）いくつ有るかとは採らないとして。
（１）Findメソッド
本来はセルの値がそっくり同じセルを探すが、引数をLookAt:=xlPartにすると「文字を含む」に出来る。
マクロの記録で、コードのおおよそはわかる。
Findは最初の該当しか指摘しない。本質問ではそれでよいが。
全て数え上げるのは次からFindNextメソッドを使う。
Sub test02()
Set x = Worksheets("Sheet1").Range("A1:E10").Find(what:="aa", LookAt:=xlPart)
If x Is Nothing Then
Else
MsgBox x.Address
End If
End Sub
ーーーーーーーーーーーー
（２）VBAのCountIF関数
そこで「＊」（ワイルドード）の利用
Sub tesr01()
x = Application.WorksheetFunction.CountIf(Range("A1:E10"), "*AA*")
MsgBox x
End Sub
以上は回答が出ている
（３）VBの　Instr関数の利用
Sub test03()
For Each cl In Range("A1:E10")
p = InStr(cl, "aa")
If p <> 0 Then
MsgBox "aaを含むセルあり" & cl.Address
Exit For '打ち切り
End If
Next
MsgBox "aaを含むセルなし"
End Sub

お礼

ありがとうございます。

回答No.3

hotosys

こんなのはどうでしょうか？
A1=りんご
A2=りんご食べたい
A3=みかん
A4=みかんはオレンジ
A5=バナナ
とします。
この時
B1=COUNTIF(A:A,"*"&A1&"*")
として、B1をB2:B5にコピーすれば、A列の各セルの重複（含む）数がB列に表示されると思います。
ここで
B1=IF(COUNTIF(A:A,"*"&A1&"*")>1,1,"")
として、B1をB2:B5にコピーすれば、重複（含む）があるセル（削除対象）のB列に1が表示されると思います。
そこで、B列を選択して[編集][ジャンプ][セル選択]で[数式][数値]を選択すると、削除対象の行のＢ列が選択されると思います。
これを行に拡張して削除すれば求めるデータになるかと思います。

Sub sample()
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row 'A列の最終行を取得
Columns("B").Insert '作業列挿入
Range("B1:B" & lastRow).Formula = "=IF(COUNTIF(A:A,""*""&A1&""*"")>1,1,"""")" 'データ範囲のB列に=IF(COUNTIF(A:A,"*"&A1&"*")>1,1,"")の式を代入
Range("B1:B" & lastRow).SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow.Delete 'B列で1のセルを行に拡張して削除
Columns("B").Delete '作業列削除
End Sub

お礼

ありがとうございます！

回答No.1

KonnaMonde

If Cells.Find(what:=Range("a" & 行), LookAt:=xlPart) Is Nothing Then
Else 'あるならば
MsgBox Range("a" & 行) & "は2個以上あります"
End If

では、Ａ列に２つ以上のセルにデータが入っていれば、データの内容に関わらず常に　「MsgBox Range("a" & 行) & "は2個以上あります"」　が、表示されませんか？
　A1→「りんご」、A2→「みかん」　のみ入れて、「Sub 重複()」を走らせてみてください。

データ群の最終行番号を取得するとき、「Cells(65536, 1).End(xlUp).Row」　の代わりに、「Cells(Rows.Count, 1).End(xlUp).Row」　を使えば、エクセル2007でも使えます。
エクセル～2003の最大行数は、256^2=65536　ですが、2007では、1024^2=1048576　行に増えています。

>どうすれば取得セル意外にも取得セルを含むセルがあるかを調べられるのでしょうか？

方法は、いろいろ考えられますが、それよりも、データの内容、と並び方で、やり方が変わります。

質問の内容通りですと簡単ですが、データの並びが、A1→「りんご食べたい」、A2→「りんご」　に変わっただけで、すんなりとはいきません。
つまり、削除したい文字列を判別して、A1、A2に共通の文字列を取り出し、その文字列だけのセルを削除しなければなりません。　しかも例題のように順に並んでいるのが確定していれば楽ですが、離れた場所にあると難しくなります。

最終的には、すべての重複データを一旦配列に取り込み、そこで並び替えなどしてデータを整理した後に必要な処理を施すようになると思います。

いずれにしても、おおよそのデータの総数、重複するであろうデータの種類の数などが分からないと、コードは書けないと思いますので、その辺りの情報を補足欄にでも書いてください。

お礼

あら！
本当だ！

「りんご」しかなくても
必ずシートには「りんご」があるからmsgboxは表示されてしまうのですね。

確認不足でした。すいません。
（そして65536行は2003までなのですね。）

このデータは
Sub 重複()を実行する前に

フィルタをかける
→重複するレコードは無視する
→重複していないデータをコピー
→別シートに貼り付け
→フィルタをかける
→昇順に並べ替え
をしています。

なので
→「りんご食べたい」
→「りんご」
になることはないと思っています。

データ量は多くても
300行までです。

再度回答いただけると助かります！
よろしくお願いします！！