この記事は、複数の列を比べて重複行を探す、というものです。

「単独の列で重複している行を探す」というサンプルは、
VBAのお勉強　VBAでExcelの重複した行を探して表示
をご覧下さい。
「重複している行を１行だけ残して削除する」というサンプルは、
VBAのお勉強　Excelで１行残して重複行を削除
をご覧下さい。

http://q.hatena.ne.jp/1205154937

「列単位でコンペアさせ、コンペア結果、重複データがある場合」という条件がはっきりしないので、

勝手に「Sheet1のA列のある行のデータがSheet2のA列のどこかにあった場合、重複データとする」としてみました。

イメージとしては、

• Sheet1のA列の1行目の値を取り、その値がSheet2のA列にあるかどうかを調べる。

あったらその値をSheet3に書き出す、なければそのまま。

• これをSheet1の最後の行まで繰り返す。

という感じでしょうか。

例えばこんな感じのワークシートがあったとします。

まずSheet1のA列の1行目の値「a」に注目します。

この値がSheet2のA列の1～7行目にあれば、Sheet3に書き出します。

この場合、「a」はありませんので何もしません。

次、Sheet1の2行目の「b」。これもないので何もしません。

次、Sheet1の3行目の「c」。これはSheet2のA列の1行目にありますので、 Sheet3に書き出します。

書き出す位置は、これが見つかった値の1個めですからA1にします。

次、Sheet1の4行目の「1」。これもないので何もしません。

次、Sheet1の5行目の「2」。これもないので何もしません。

次、Sheet1の6行目の「3」。これはSheet2のA列の4行目にありますので、 Sheet3に書き出します。

書き出す位置は、これが見つかった値の2個めですからA2にします。

これでSheet1の全部の行を見ました。

これでおっけい(^^)

ではこれをプログラムにしてみます。

Excelから「ツール」→「マクロ」→「Visual Basic Editor」でプロジェクトの中の「Sheet1」をダブルクリック、するとコードを記述するウィンドウが表示されます。

まず、Sheet1のA列を一行ずつ見ていく必要があるので、とりあえず、イミディエイトウィンドウに Sheet1のA列を1行ずつ表示するプログラムを作ってみます。

この記事でやったことと全く同じですね(^^;)

Sub test()

    Dim lastgyou As Integer
    Dim i        As Integer
    
    ActiveSheet.Range("A1").End(xlDown).Select
    lastgyou = ActiveCell.Row
    
    For i = 1 To lastgyou
        
        Debug.Print (ActiveSheet.Cells(i, 1).Value)
    
    Next

End Sub

で、実行してみます。

ん、いいんでないかい(^^)

次、こうやって取り出した値を1つずつ、Sheet2にあるかどうかを探す事になりますので、 Sheet2も同じように、A列の何行目までデータが入っているかを調べてみます。

。。。はて。上のプログラムだと、ActiveSheetってなってますので、今現在選択しているシートの事しかわからないですね。

というか、これじゃ、このプログラムを実行したときに選択されているシートの値を表示しちゃうかな？

試しに、Sheet2を選択した状態でこのプログラムを動かしてみると、

(^^;)Sheet2の値が表示されちゃいました。

これじゃ駄目ですね。 どうしたもんか。。。

どのシートが選択されている状態でもSheet1の値を見るようにしないとまずいですね。

プログラムでシートを選択する方法を調べてみます。

Yahoo!で「vba excel シートの選択」で検索すると、こちらのページが見つかりました。

Sheets(“Sheet1″).Select で良いみたいですね。 これをプログラムの先頭に入れてみます。

Sub test()
    
    Dim lastgyou As Integer
    Dim i        As Integer
    
    Sheets("Sheet1").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    lastgyou = ActiveCell.Row
    
    For i = 1 To lastgyou
        
        Debug.Print (ActiveSheet.Cells(i, 1).Value)
    
    Next

End Sub

Sheet2を選択した状態で、

プログラムを実行してみます。

ん、Sheet1に切り替わってますね。いいかんじ(^^)

Sheet2について調べたければ Sheets(“Sheet2″).select に切り替えればいいですね。

それでは、Sheet1とSheet2、それぞれ何行目までデータが入っているかを調べてみます。

Sub test()
    
    Dim sheet1lastgyou As Integer
    Dim sheet2lastgyou As Integer
    
    Sheets("Sheet1").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet1lastgyou = ActiveCell.Row
    
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet2lastgyou = ActiveCell.Row
    
    Debug.Print ("sheet1は" + Str(sheet1lastgyou) + "行目まで")
    Debug.Print ("sheet2は" + Str(sheet2lastgyou) + "行目まで")

End Sub

Sheet1の最終行の行番号がsheet1lastgyouに入り、Sheet2がsheet2lastgyouです。

ん、よいようです(^^)

それではとりあえず、Sheet1のデータがSheet2にあるかどうかを調べるプログラムを作ってみます。

Sub test()

    Dim i              As Integer
    Dim j              As Integer
    Dim check          As String
    Dim sheet1lastgyou As Integer
    Dim sheet2lastgyou As Integer
    
    'Sheet1の最終行を求める
    Sheets("Sheet1").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet1lastgyou = ActiveCell.Row
    
    'Sheet2の最終行を求める
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet2lastgyou = ActiveCell.Row
    
    'Sheet1を1行目から最終行まで
    For i = 1 To sheet1lastgyou
        
        'Sheet1を選択します
        Sheets("Sheet1").Select
        
        'Sheet1のi行目の値を取り出します
        check = ActiveSheet.Cells(i, 1).Value
        
        'Sheet2を選択します
        Sheets("Sheet2").Select
        
        'Sheet2を1行目から最終行まで
        For j = 1 To sheet2lastgyou
            
            'Sheet2のj行目の値とcheckの値が同じだったら
            If ActiveSheet.Cells(j, 1).Value = check Then
                
                'とりあえずイミディエイトウィンドウに表示します
                Debug.Print (check)
            
            End If
        
        Next
    Next
End Sub

プログラムにコメントを入れてみました。やってることは、さっき言葉で書いたことそのままです。

動かしてみます。

ん、重複している値（「c」と「3」）が表示されました(^^)

あとは、この見つけた値をSheet3に書き出していけばいいですね。

1つ目を見つけたら、Sheet3のA1にその値を入れる、

2つ目を見つけたら、Sheet3のA2にその値を入れる、

以下繰り返しって感じで。

今何個目なのかを入れておく変数を作り、見つけたら、セルに値を入れ、変数を1つ増やす、これで行きます。

Sub test()
    Dim i              As Integer
    Dim j              As Integer
    Dim check          As String
    Dim sheet1lastgyou As Integer
    Dim sheet2lastgyou As Integer
    Dim sheet3gyou     As Integer
    
    'Sheet1の最終行を求める
    Sheets("Sheet1").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet1lastgyou = ActiveCell.Row
    
    'Sheet2の最終行を求める
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet2lastgyou = ActiveCell.Row
    
    'Sheet3の行数を0にしておく
    sheet3gyou = 0
    
    'Sheet1を1行目から最終行まで
    For i = 1 To sheet1lastgyou
        
        'Sheet1を選択します
        Sheets("Sheet1").Select
        
        'Sheet1のi行目の値を取り出します
        check = ActiveSheet.Cells(i, 1).Value
        
        'Sheet2を1行目から最終行まで
        For j = 1 To sheet2lastgyou
            
            'Sheet2を選択します
            Sheets("Sheet2").Select
            
            'Sheet2のj行目の値とcheckの値が同じだったら
            If ActiveSheet.Cells(j, 1).Value = check Then
                
                'Sheet3に代入するセルの行数を1つ増やします。
                sheet3gyou = sheet3gyou + 1
                
                'Sheet3を選択します
                Sheets("Sheet3").Select
                
                'セルに見つけた値を代入します
                ActiveSheet.Cells(sheet3gyou, 1).Value = check
            End If
        Next
    Next
End Sub

sheet3gyouという変数を設け、最初は0、見つけたら1つ増やして、 Sheet3に切り替え、見つけた値をセルに代入する、という感じです。

プログラムを動かしてみると。。。

ん、いいんでないかい？(^^)

これで完成、、、と思ったんですけど。

今入ってるデータだったら問題ないんですけど、 Sheet1内、Sheet2内で重複しているデータがあった場合、例えばこんな感じ。

この状態で実行すると、

こんな感じ。「a」はいいとして、「b」「c」が2つ出てます。

「b」はSheet1に2つありますから、それぞれがSheet2の1つと一致します。

なので、2つ出ます。「c」はSheet1の1つがSheet2の2つと一致しますので、やはりこれも2つ出ます。

重複しているものは出ているので、これでいいっちゃいいんですけど、ここは、

こう出たほうがスマートですかね？(^^;)

さて、どうやろうかな。

Sheet2の中で重複している場合（この場合「c」）は、Sheet2を上から見ていくとき、 1つ目が見つかった段階で、もうその値を探すのを止めてしまえばよさそうです。

見つかった場合、forのループを抜け出してしまう感じですね。

Sub test()
    Dim i              As Integer
    Dim j              As Integer
    Dim check          As String
    Dim sheet1lastgyou As Integer
    Dim sheet2lastgyou As Integer
    Dim sheet3gyou     As Integer
    
    'Sheet1の最終行を求める
    Sheets("Sheet1").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet1lastgyou = ActiveCell.Row
    
    'Sheet2の最終行を求める
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet2lastgyou = ActiveCell.Row
    
    'Sheet3の行数を0にしておく
    sheet3gyou = 0
    
    'Sheet1を1行目から最終行まで
    For i = 1 To sheet1lastgyou
        
        'Sheet1を選択します
        Sheets("Sheet1").Select
        
        'Sheet1のi行目の値を取り出します
        check = ActiveSheet.Cells(i, 1).Value
        
        'Sheet2を1行目から最終行まで
        For j = 1 To sheet2lastgyou
            'Sheet2を選択します
            
            Sheets("Sheet2").Select
            'Sheet2のj行目の値とcheckの値が同じだったら
            
            If ActiveSheet.Cells(j, 1).Value = check Then
                
                'Sheet3に代入するセルの行数を1つ増やします。
                sheet3gyou = sheet3gyou + 1
                
                'Sheet3を選択します
                Sheets("Sheet3").Select
                
                'セルに見つけた値を代入します
                ActiveSheet.Cells(sheet3gyou, 1).Value = check
                
                '1つ目が見つかったので、ループから抜けます
                Exit For
            End If
        Next
    Next
End Sub

見つかった後、セルに代入した後でExit forでループを抜け出します。実行してみると、

ん、「c」は1つだけになりました(^^)。

後は、Sheet1内で重複していた場合ですね。

Sheet1を1行ずつ見ていって、これからチェックしようとする値（checkという変数に代入しています）が、それまで見てきた行の中にあるかどうかをチェックし、もしもあった場合、その行を飛ばす、というのでどうでしょうか。

これなら、Sheet1の3行目の「b」を見ているときは、すでに2行目に「b」がありますから、飛ばすことになります。

というわけで、プログラムにしてみます。

Sub test()
    Dim i              As Integer
    Dim j              As Integer
    Dim k              As Integer
    Dim atta           As Integer
    Dim check          As String
    Dim sheet1lastgyou As Integer
    Dim sheet2lastgyou As Integer
    Dim sheet3gyou     As Integer
    
    'Sheet1の最終行を求める
    Sheets("Sheet1").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet1lastgyou = ActiveCell.Row
    
    'Sheet2の最終行を求める
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    sheet2lastgyou = ActiveCell.Row
    
    'Sheet3の行数を0にしておく
    sheet3gyou = 0
    
    'Sheet1を1行目から最終行まで
    For i = 1 To sheet1lastgyou
        
        'Sheet1を選択します
        Sheets("Sheet1").Select
        
        'Sheet1のi行目の値を取り出します
        check = ActiveSheet.Cells(i, 1).Value
        
        'attaという変数を0にします。
        atta = 0
        
        'もし、Sheet1の2行目以降を見ている場合
        If i >= 2 Then
            
            '今見ている行の前の行までに今回の値があるかどうかを探します
            
            For k = 1 To i - 1
                
                If ActiveSheet.Cells(k, 1).Value = check Then
                    atta = 1
                    Exit For
                End If
            
            
            Next
        End If
        
        'もし、atta=0ならば、Sheet2を探します。
        If atta = 0 Then
            
            'Sheet2を1行目から最終行まで
            For j = 1 To sheet2lastgyou
                
                'Sheet2を選択します
                Sheets("Sheet2").Select
                
                'Sheet2のj行目の値とcheckの値が同じだったら
                If ActiveSheet.Cells(j, 1).Value = check Then
                    
                    'Sheet3に代入するセルの行数を1つ増やします。
                    sheet3gyou = sheet3gyou + 1
                    
                    'Sheet3を選択します
                    Sheets("Sheet3").Select
                    
                    'セルに見つけた値を代入します
                    ActiveSheet.Cells(sheet3gyou, 1).Value = check
                    
                    '1つ目が見つかったので、ループから抜けます
                    Exit For
                
                End If
            
            Next
        End If
    Next
End Sub

新たに、attaとkという変数を作りました。

もし、Sheet1の2行目以降を探す場合、それ以前の行の値を For k=1 to i-1 ということで、1行目から、今探している行（i）の1つ前までループし、その行のセルの値が、checkの値と同じかどうかを調べ、同じだったら、attaという変数に1を入れます。

もし見つからなかったら、attaの変数は0のままですので、 attaが0だったら、今度はSheet2を調べる、という事になります。

プログラムを実行すると、、、

ん、いいんでないかい(^^)

いちおう、これで完成、でいいかな・・・？

こちらにアップしておきます→vbastudy_0006.xls

http://q.hatena.ne.jp/1199348584

まず、ワークシート名の一覧を取得します。

Yahoo!で、「vba excel ワークシート名　取得」で検索すると、

http://www.relief.jp/itnote/archives/000960.php
が出てきました。

ここに載っているサンプルは、シート名をセルに代入していくようなので、これをDebug.Printするようにしてみます。

Sub test()
        Dim objSheet As Object
        For Each objSheet In ActiveWorkbook.Sheets
                Debug.print objSheet.Name
        Next
End Sub

ん、いい感じ(^^)

次は、「シート名が「はてな」か、半角数字の場合」ですね。
シート名が「はてな」は簡単だけど、「半角数字の場合」が難しいですね。

他の言語だと、「正規表現」なんかを使うところだと思うので、Yahoo!で「vba excel 正規表現」で検索してみると、、、
http://codezine.jp/a/article/aid/1655.aspx
によると、「RegExpオブジェクト」なるものを参照設定しないと駄目らしい。
この手の「参照設定」は、プログラムを使う際設定しないといけないと思うので、あんまり好きじゃないんですよね～。
「このプログラムを使いたいなら、事前にいろいろ設定して～」というのは、めんどくさいですし。

なので、参照設定とかを出来るだけ使わないでやってみることにします。

Yahoo!で「vba excel 半角数字か」で検索すると、
http://oshiete1.goo.ne.jp/c257.html?start=7296
が見つかりました。この中から、
半角数字かどうかの判定
http://oshiete1.goo.ne.jp/qa2404154.html
を見ていくと、
http://homepage1.nifty.com/rucio/main/technique/InputChk2.htm
が紹介されています。

これによると、IsNumericなる関数があるようですが、それでは対象文字列が「3D2」などの場合、数字じゃないのに数字とみなされてしまうようなので、一文字ずつばらしてみていったほうが良いみたいですね。

対象の数字が半角数字かどうかをチェックする関数 hankakusuujicheckを作ってみます。
hankakusuujicheck(“123″)→true
hankakusuujicheck(“abc”)→false
こんな感じになるように。

Sub test()
        If hankakusuujicheck("123") Then
                        Debug.Print "123は半角数字だよ"
                Else
                        Debug.Print "123は半角数字じゃないよ"
        End If

        If hankakusuujicheck("abc") Then

                        Debug.Print "abcは半角数字だよ"

                Else

                        Debug.Print "abcは半角数字じゃないよ"

        End If

End Sub

Function hankakusuujicheck(ByVal checkvalue As String) As Boolean

        Dim i As Integer

        For i = 1 To Len(checkvalue)

                If Not Mid(checkvalue, i, 1) Like "[0-9]" Then Exit Function

        Next

        hankakusuujicheck = True

End Function

よいようです(^^)

では、シート名が「はてな」か半角数字の場合、シート名を表示させてみます。

Sub test()
        Dim objSheet As Object
        Dim Sheetmei As String
        For Each objSheet In ActiveWorkbook.Sheets
                Sheetmei = objSheet.Name
                If Sheetmei = "はてな" Or hankakusuujicheck(Sheetmei) Then

                        Debug.Print Sheetmei

                End If

        Next

End Sub

Function hankakusuujicheck(ByVal checkvalue As String) As Boolean

        Dim i As Integer

        For i = 1 To Len(checkvalue)

                If Not Mid(checkvalue, i, 1) Like "[0-9]" Then Exit Function

        Next

        hankakusuujicheck = True

End Function

Excelのワークシート名を「はてな」「123」「ほげ」に変えて、プログラムを実行してみます。

ん、よさげ(^^)

次に、「当該シート内におけるA列の全行にある共通の文字列を
「ももんが」に置換するというマクロを作ってください。」とのこと。

「A列の全行」となると、まずA1から縦にどこまでデータが入ってるのかを調べないといけないですね。最後の行を探す方法を検索してみます。

Yahoo!で「excel vba セル 最終行」で検索すると、
http://www.moug.net/tech/exvba/0050088.htm
のページが見つかりました。やりたいことそのまんまです(^^)

Sub test()
    ActiveSheet.Range("A1").End(xlDown).Select
End Sub

として、ExcelのシートのA列にデータを入れてみて、実行します。

ん、確かに、A列でデータが入ってる最後の行まで移動しました。
これで、A列がどの行までデータが入ってるかは取得できました。

A1からこのセルまでの範囲に入ってる文字列を調べる、ということなので、とりあえず、A1からこのセルまでの値を抜き出してみたいと思います。

A1から上の方法で見つけたセルまでを繰り返す、ってことは、

for i=1 to (今見つけたセルの行番号)
Debug.print(「A（i）」のセルの中身)
next i

こんな感じになると思うけど。今いるセルの行番号ってどうやって取得するのかな？
Yahoo!で「excel vba セル 行番号」で検索。
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q116001856
によると、ActiveCell.Row で今アクティブなセルの行番号が取得できるらしいので、

Sub test()
    Dim lastgyou As Integer
    Dim i As Integer

    ActiveSheet.Range("A1").End(xlDown).Select
    lastgyou = ActiveCell.Row
    For i = 1 To lastgyou
        Debug.Print (ActiveSheet.Cells(i, 1).Value)
    Next
End Sub

lastgyouという変数に、最後の行の行番号を代入して、
for ループで、１～lastgyouまでのセルの値を表示してみます。

ん、いいんでないかい？(^^)

さて、次は「A列に共通の文字列」を探す、ということなんですが。質問者さんの例で、
「とびうお01」
「とびうお02」
「新とびうお」
とありますが、人間が見て「とびうお」が共通してるなってのは一目瞭然なんですけど、これをプログラムでどうやらせるか、ですよね。

まず、共通してる文字列といっても、「と」「び」「う」「お」の１文字ずつみても、それぞれ共通してますよね？これを「ももんが」に置き換えると、
「ももんがももんがももんがももんが01」
「ももんがももんがももんがももんが02」
「新ももんがももんがももんがももんが」
ってなことにもなりますけど、これは質問者さんの意図するとこではない
ですので、共通していて一番長い文字列、を「ももんが」に置き換える、としてみます。

「全てのA列に共通の文字列」ということは、
「A1に入ってる値の一部分が、A2以降のすべてに含まれている文字列」
と考えればよいですよね？

例えば、上の例ですと、「とびうお01」の「とびうお」という文字列が、それ以降の行に全て入っていますから、これが共通する文字列となります。

それでは、とりあえず、指定した文字列がA2から最後の行までに含まれているかどうかを調べるサブルーチンを作ってみます。

Sub test()
    If zenbuarukadouka("とびうお") Then
        Debug.Print "とびうおはA2以降全てにあります"
        Else
        Debug.Print "とびうおはA2以降でない行もあります"
    End If

    If  zenbuarukadouka("とびうお0") Then
        Debug.Print "とびうお0はA2以降全てにあります"
        Else
        Debug.Print "とびうお0はA2以降でない行もあります"
    End If

End Sub
Function zenbuarukadouka(ByVal check As String) As Boolean
    Dim lastgyou As Integer
    Dim i As Integer
    ActiveSheet.Range("A1").End(xlDown).Select
    lastgyou = ActiveCell.Row

    For i = 2 To lastgyou
        If InStr(ActiveSheet.Cells(i, 1).Value, check) = 0 Then Exit Function
    Next

    zenbuarukadouka = True

End Function

zenbuarukadouka()は、与えられた文字列がA2～最後の行まで含まれているかどうかをチェックします。InStr関数を使って、各セルの値に含まれていなかったら、その場で関数を終了しFalseを返します。全ての行に含まれていたら（つまり、for nextがすべてループしたら）Trueの値を返します。

さて、ということで、このzenbuarukadouka()に、A1の文字列の一部分を与えていけばいいわけですけど、、、

例えば、A1に「あいうえお」という文字が入っていたとします。
A2以降に共通に入っている文字列を zenbuarukadouka()で調べる際に、どのような値を渡せばよいかですが、

長い順から調べていくということですから、５文字の
zenbuarukadouka(“あいうえお”)ですね。次に長いのは４文字の
zenbuarukadouka(“あいうえ”)と、同じく４文字の
zenbuarukadouka(“いうえお”)ということになります。
次は３文字の
zenbuarukadouka(“あいう”)
zenbuarukadouka(“いうえ”)
zenbuarukadouka(“うえお”)
続いて２文字、
zenbuarukadouka(“あい”)
zenbuarukadouka(“いう”)
zenbuarukadouka(“うえ”)
zenbuarukadouka(“えお”)
最後に１文字、
zenbuarukadouka(“あ”)
zenbuarukadouka(“い”)
zenbuarukadouka(“う”)
zenbuarukadouka(“え”)
zenbuarukadouka(“お”)
となります。
これを上から順に調べていって、全ての行で見つかったものがあれば、それが一番長い共通の文字列となります。

Sub test()
Dim i As Integer
Dim j As IntegerDim A1 As String

A1 = "あいうえお"
For i = Len(A1) To 1 Step -1
    For j = 1 To Len(A1) - i + 1
        Debug.Print Mid(A1, j, i)
    Next j
Next i

End Sub

A1という変数に入れられた文字列で、チェック対象となる文字列をDebug.printするプログラムです。

iとjという変数がありますが、iは5～1へ変化します。これは、A1の文字数である5から一番短い文字数の1まで変化する、ということです。
jは、A1の文字列を抜き出す際、何文字目から抜き出すか、を表しています。
これは i によって、値の範囲が変わります。
iが5、つまり、A1の文字数と一緒であれば、jは1～1、つまり、１文字目から5文字抜き出します（あいうえお）。
iが4の場合は、jは1～2、つまり、１文字目から4文字抜き出し（あいうえ）、次に2文字目から4文字抜き出します（いうえお）。
以下、３文字の場合、２文字の場合、１文字の場合も同じように1～3文字目、1～4文字目、1～5文字目が抜き出されるようになっています。

あとは、A1から最後の行まで、見つけた文字列で置換していく部分さえ出来れば完成かな？

A1から最後の行まで、指定した文字列を”ももんが”に置換するプログラムは以下のとおりです。

Sub test()
 chikan ("とびうお")
End Sub

Function chikan(ByVal henkanmoto As String)
 Dim i As Integer
 Dim lastgyou As Integer
 ActiveSheet.Range("A1").End(xlDown).Select
 lastgyou = ActiveCell.Row
 For i = 1 To lastgyou
    ActiveSheet.Cells(i, 1).Value = Replace(ActiveSheet.Cells(i, 1).Value, henkanmoto, "ももんが")
 Next i
End Function

最後の行を求めるのは、さっきまでと同じやりかたで、for nextでループして、全ての行のセルをReplaceを使って、変換元の文字列を”ももんが”に置き換えます。

というデータで実行すると、

となります。

これで必要な機能は全て揃ったので、全部を組み合わせたプログラムを作ってみます。

Sub text()
    Dim objSheet As Object
    Dim Sheetmei As String
    Dim A1 As String
    Dim i As Integer
    Dim j As Integer
    Dim nukidashi As String
    Dim atta As Integer

'現在開いているBookのすべてのSheetをチェックします
  For Each objSheet In ActiveWorkbook.Sheets
    'Sheetmei にシート名を代入します
    Sheetmei = objSheet.Name
    'もし、シート名が「はてな」、もしくは、半角数字の場合、
    If Sheetmei = "はてな" Or hankakusuujicheck(Sheetmei) Then
        'そのシート名のシートを選択します。
        ActiveWorkbook.Sheets(Sheetmei).Select
        '今選択されているシートのA1のセルの値を、A1という変数に代入します。
        A1 = ActiveSheet.Cells(1, 1).Value
        '見つかった場合、ループから抜け出すための変数を0にしておきます。
        atta = 0
        'A1の変数の文字列を長い順に抜き出します。
        For i = Len(A1) To 1 Step -1
            For j = 1 To Len(A1) - i + 1
                'nukidashiという変数に、A1の文字列を抜き出したものを代入します。
                nukidashi = Mid(A1, j, i)
                'もし、nukidashiの文字列がA2以降、すべての行に入っていたら、
                'attaという変数を　1　にして、内側のループを抜けます
                If zenbuarukadouka(nukidashi) Then
                    atta = 1
                    Exit For
                End If
            Next j
            'もし、attaが1の場合、もう見つかっているので、外側のループも抜けます
            If atta = 1 Then Exit For
        Next i
        'もし、attaが1の場合、共通する文字列が見つかったので、A2以降すべてを置き換えます
        If atta = 1 Then
         chikan (nukidashi)
        End If
    End If
  Next
End Sub

Function hankakusuujicheck(ByVal checkvalue As String) As Boolean
Dim i As Integer
For i = 1 To Len(checkvalue)
    If Not Mid(checkvalue, i, 1) Like "[0-9]" Then Exit Function
Next
hankakusuujicheck = True
End Function

Function zenbuarukadouka(ByVal check As String) As Boolean
    Dim lastgyou As Integer
    Dim i As Integer

    ActiveSheet.Range("A1").End(xlDown).Select
    lastgyou = ActiveCell.Row
    For i = 2 To lastgyou
        If (InStr(ActiveSheet.Cells(i, 1).Value, check) = 0) Then Exit Function
    Next
    zenbuarukadouka = True
End Function

Function chikan(ByVal henkanmoto As String)
Dim i As Integer
Dim lastgyou As Integer
ActiveSheet.Range("A1").End(xlDown).Select
lastgyou = ActiveCell.Row
For i = 1 To lastgyou
    ActiveSheet.Cells(i, 1).Value = Replace(ActiveSheet.Cells(i, 1).Value, henkanmoto, "ももんが")
Next i
End Function

ループでシート名を抜き出した後、「はてな」か半角数字の場合、そのシートを選択する必要があるので、
ActiveWorkbook.Sheets(Sheetmei).Select
で選択しています。

それと、文字列の抜き出しを行っている際に、途中で見つかった場合、attaという変数を用いて、ループを抜け、その後の置換処理を行うかどうかも、attaの変数の値を見て判断しています。

では、実際にデータをいれてこのプログラムを動かしてみます。

という状態で実行してみます。

正常に動作しました(^^)

このxlsファイルを置いておきます→vbastudy_0005.xls