61本目：「ふりがな」の取得と設定

出題：「ふりがな」の取得と設定

#VBA100本ノック 61本目
A列の名称には「ふりがな」が正しく入っていません。
「マスタ」シートのA列には「ふりがな」が正しく設定されているので、ここから「ふりがな」を取得しA列に「ふりがな」を設定してください。
マスタなしは赤文字にしてください。（既定の文字色は自動）
※シートは任意

◇ 出題ページはこちら

ソースコード

Option Explicit

' 100本ノック061：「ふりがな」の取得と設定
Sub ふりがなをマスタから取得する()

    WSdata.Columns(1).Font.Color = False
    WSdata.Columns(1).Phonetic.Visible = True

    Dim R_data As Long
    For R_data = 2 To Get最終行(WSdata)
    
        Dim R_マスタ As Long
        R_マスタ = Match行番号(WSdata.Cells(R_data, 1), WSマスタ.Columns(1))
        
        If R_マスタ = 0 Then
            WSdata.Cells(R_data, 1).Font.Color = vbRed
        Else
            Call ふりがなをコピーする(WSマスタ.Cells(R_マスタ, 1), WSdata.Cells(R_data, 1))
        End If
    
    Next

End Sub

Sub ふりがなをコピーする(コピー元セル As Range, 反映先セル As Range)

    反映先セル.Phonetics.Delete
    
    Dim ふりがな As Phonetics
    For Each ふりがな In コピー元セル.Phonetics
    
        反映先セル.Phonetics.Add ふりがな.Start, ふりがな.Length, ふりがな.Text
    
    Next

End Sub

Option Explicit

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 行番号の検索
' ◆ ブログ未掲載
Function Match行番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Dim x: x = CDbl(検索値)
        If Err.Number = 0 Then
            Match行番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Row - 1
            Exit Function
        End If
    End If

    Match行番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Row - 1

End Function

解説

ふりがなを取得・設定する問題です。

ふりがなを簡単に設定する場合は、以下のコードでも十分です。

反映先セル.Phonetic.Text = コピー元セル.Phonetic.Text

　
しかし、実際のふりがなは↓の画像のように、

どの文字に振られたかなかを情報として持っています。

これも含めて完璧に反映させる場合は、
RangeオブジェクトのPhoneticsコレクション内をループし、
各Phoneticsオブジェクトをひとつずつコピーする必要があります。

Sub ふりがなをコピーする(コピー元セル As Range, 反映先セル As Range)

    反映先セル.Phonetics.Delete
    
    Dim ふりがな As Phonetics
    For Each ふりがな In コピー元セル.Phonetics
    
        反映先セル.Phonetics.Add ふりがな.Start, ふりがな.Length, ふりがな.Text
    
    Next

End Sub

　
実際の業務でふりがなを正確に操作する必要がある方は、
この関数を汎用関数として持っておきましょう。