エクセルのVBAについて

VBA超初心者です。
ですが急ぎなので申し訳ありません。

シート１には、500個くらいの氏名が様々なセルに散らばっています。

シート２のA列には、シート１の500個くらいの氏名が入っています。
シート２のB列には、A列の氏名のフリガナが入っています。

やりたいことは以下の内容です。


シート２の表（Ａ列Ｂ列）を使って
シート１の氏名の上にフリガナを挿入することは可能でしょうか。

エクセルのフリガナの機能を使うと、最近のキラキラネームのような変換されない文字が
フリガナとして出てきてしまいます。また一つ一つ修正するのはかなり大変なので
せっかくあるシート２の名簿（Ｂ列は正しいフリガナになっています）を使えないかと
思い、ご質問させていただきました。

No.3 回答者： 30246kiku 回答日時： 2015/09/19 09:58

解決されてましたらスルーしてください

素直にコード記述してみました

Sheet2 の A1 ～ A 列最後までの2列分(A、B列)を変数 vA に読み込んで
Sheet1 全部を対象に vA(i,1) ･･･
氏名と一致するものがあるかを1つずつ確認していきます

Set r = .Cells.Find(vA(i, 1), LookAt:=xlWhole)

で、同じものが見つかったら、
そのセル番地を覚えておいて
vA(i, 2) の読みを ふりがな に設定して
同じ氏名がまだあるか　Set r = .Cells.FindNext(r)
最後まで探してなかったら、最初に戻って探す動きをするので
初めに覚えていたセル番地になったら同じ氏名はもう無いということで
Do ～ Loop を抜けます
この Do ～ Loop の間、氏名を削除しているわけではないので、
見つからない状態にはなりませんね

vA 行数分処理したら終わりです


Public Sub Samp1()
　　Dim r As Range
　　Dim vA As Variant
　　Dim sAdr As String
　　Dim i As Long

　　With Worksheets("Sheet2")
　　　　vA = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
　　End With

　　Application.ScreenUpdating = False
　　With Worksheets("Sheet1")
　　　　For i = 1 To UBound(vA) ' 1行目から
　　　　　　If (vA(i, 1) <> "") Then
　　　　　　　　Set r = .Cells.Find(vA(i, 1), LookAt:=xlWhole)
　　　　　　　　If (Not r Is Nothing) Then
　　　　　　　　　　sAdr = r.Address
　　　　　　　　　　Do
　　　　　　　　　　　　r.Phonetic.Text = vA(i, 2)
　　　　　　　　　　　　Set r = .Cells.FindNext(r)
　　　　　　　　　　Loop While (r.Address <> sAdr)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
　　Application.ScreenUpdating = True
End Sub

No.2 回答者： WindFaller 回答日時： 2015/09/17 23:53

こんばんは。

#1さん、すみません、またまた後付してしまいました。
この質問では、いろんな例を考えてしまいました。

もう少し、具体的に示していると良いのですが。
一応、苗字と名前がセットになった正しい名簿ということで、話を進めさせていただきます。
したがって、Sheet1側とSheet2側の名前が、例えば、「日本　太郎」と、「日本太郎」とは、別の名前になってしまいます。そのためには、第一案としては、Sheet2側の名前とSheet1側の記述がまったく同じようにしなくてはなりません。Sheet1側の名前らしきものは、すべてスペース削除する方法です。

しかし、第二案として、それができないとなると、今の段階では、具体的には考えていませんが、特別な検索(正規表現）を施してあげなくてはならないでしょう。漢字1つずつを調べることになりそうですから、遅いマクロになるはずです。

その点を、よくご確認ください。

以下のマクロは、文字のFriganaプロパティに、ふりがなの文字を入れるのみですから、確認は、Phonetic 関数で、入っているか確認してください。一応、このマクロにもエラーを検出するコードは置いてあります。ブロックコメントを外せばよいです。データは、イミディエイトウィンドウに出てきます。
また、最初から、Phonetic 関数を置いている場合は、何らかの不都合で、ふりがなを取り出さないことがあります。その場合は、ショートカット　[Shift + F9] を押して見てください。それで出てこなければ、失敗しています。

'//標準モジュール
Sub AddKiraKiraName()
　Dim c As Range
　Dim FirstAddress As String '検索の最初のアドレス
　Dim n As Variant
　Dim oName As Range
　Dim cnt As Long
　Dim SearchArea As Range
　Application.ScreenUpdating = False
　On Error Resume Next
　'定数の文字のみの検索にしました。
　Set SearchArea = Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
　If SearchArea Is Nothing Then Exit Sub
　On Error GoTo 0
　With Worksheets("Sheet2") 'ふりがなリストは、シート2のA2行目から入っているとします。
　　For Each n In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　　If n Like "*[一-龠]*" Then　'ひらがな・カタカナだけの場合は除外
　　　　Set oName = n
　　　　'現行では、全部一致しないといけないようになっている
　　　　With SearchArea
　　　　　Set c = .Find( _
　　　　　What:=oName.Value, _
　　　　　LookIn:=xlValues, _
　　　　　LookAt:=xlWhole)
　　　　　If Not c Is Nothing Then
　　　　　　FirstAddress = c.Address
　　　　　　Do
　　　　　　　c.Phonetic.Text = oName.Offset(, 1).Value
　　　　　　　cnt = cnt + 1
　　　　　　　''※もし、ご動作するようでしたら、以下のプロックコメントを外してください。
'　　　　　　　'If c.Phonetic.Text Like "*[一-龠]*" Then
'　　　　　　　'　Debug.Print c.Address; c.Value
'　　　　　　　'End If
　　　　　　　Set c = .FindNext(c)
　　　　　　　If c.Address = FirstAddress Then Exit Do
　　　　　　Loop Until c Is Nothing
　　　　　End If
　　　　End With
　　　End If
　　Next n
　End With
　Application.ScreenUpdating = True
　MsgBox cnt & "セルに,ふりがなを入れ終了しました.", vbInformation
End Sub
'参考資料
'http://matome.naver.jp/odai/2137697259762667901

No.1 回答者： soixante 回答日時： 2015/09/17 22:57

シート２の1行目から氏名と振り仮名が入っているとして以下。

'----------------------------------------------------------

Sub zzz()
Dim r As Integer, c As Integer
Dim Rng As Range, Sel As Range
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim Kanji As String, Furig As String
Set Ws1 = Worksheets(1)
Set Ws2 = Worksheets(2)
Set Rng = Ws1.UsedRange

r = 2
Do While Ws2.Cells(r, 1).Value <> ""
Kanji = Ws2.Cells(r, 1).Value
Furig = Ws2.Cells(r, 2).Value

For Each Sel In Rng
If Sel.Value = Kanji Then
Sel.Offset(-1, 0).Value = Furig
Exit For
End If
Next Sel
r = r + 1
Loop
Set Ws1 = Nothing
Set Ws2 = Nothing
Set Rng = Nothing

End Sub
'----------------------------------------------------------
どうでしょうか。