Sub RubiMacro()
'
'  ルビ振る元文字《ルビ文字》形式のテキストをwordのルビに変換するマクロ
'
'
'始端に戻す
    ActiveDocument.Range(0, 0).Select
    Set rng = ActiveDocument.Range(0) '先頭から末尾までRangeを設定
    Do While rng.Find.Execute("《") 'ループ始端
        
        ' 振る方のルビ文字の取得
        ActiveDocument.Range(0, 0).Select
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "《" & "*" & "》"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchFuzzy = False
            .MatchWildcards = True
        End With
        Call Selection.Find.Execute
        Set ret = Selection.Range
        lng = Len(ret)
        rubi = Mid(ret, 2, lng - 2) 'ルビ文字取得
        
        ' 文書頭に戻してルビを振られる方の文字位置の取得
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        ActiveDocument.Range(0, 0).Select
        With Selection.Find
            .Text = "《"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindAsk
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchFuzzy = False
            .MatchWildcards = True
        End With
        Call Selection.Find.Execute
        'ルビを振られる方の文字の取得
        Selection.Start = Selection.End - 2
        flg = 0
        Do While flg <= 1
            char = Selection.Range
            chr1 = Left(char, 1)
            If Asc(chr1) >= &H889F Then
                Selection.Start = Selection.Start - 1
            Else
                flg = flg + 1
            End If
        Loop
        
        ' ルビ振り
        With Selection
             .Start = Selection.Start + 1
             .End = Selection.End - 1
            .Range.PhoneticGuide Text:=rubi, Alignment:= _
                wdPhoneticGuideAlignmentOneTwoOne, Raise:=9, FontSize:=6, FontName:= _
                "ＭＳ 明朝"
        End With
        
        
        ' 文書頭に戻して《*》削除
        ActiveDocument.Range(0, 0).Select
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "《*》"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchFuzzy = False
            .MatchWildcards = True
        End With
        Selection.Find.Execute
        With Selection
            If .Find.Forward = True Then
                .Collapse Direction:=wdCollapseStart
            Else
                .Collapse Direction:=wdCollapseEnd
            End If
            .Find.Execute Replace:=wdReplaceOne
            If .Find.Forward = True Then
                .Collapse Direction:=wdCollapseEnd
            Else
                .Collapse Direction:=wdCollapseStart
            End If
            .Find.Execute
        End With
        
        Set rng = ActiveDocument.Range(0) '先頭から末尾までRangeを設定
    Loop
End Sub