セル内のフォント設定をspanタグに変換する関数

一箇所バグがあったので修正

Public Function GetFontInterior(rCell As Range) As String

  Dim i As Long, j As Long  'セルのテキスト評価用カウンタ
  Dim sRet As String '返すテキストを格納
  Dim sAttr As String 'style に入れる属性値
  Dim nDone As Long '何文字目まで変換、戻り値用変数に格納したか
  Dim ChkiFont As Font
  Dim ChkjFont As Font
  Dim sTemp As String '作業用

'09/07/28 ユーザ定義関数として使えるように再計算させる
  Application.Volatile
'09/07/28 一旦は複数セルには対応しない
  '複数セルが指定されている場合
  If rCell.Count > 1 Then
    GetFontInterior = "複数セルには対応してません"
    Exit Function
  End If

  sRet = ""
  sTemp = rCell.Text
  i = 1
  nDone = 0
  Do While i <= Len(rCell.Text)
    Set ChkiFont = rCell.Characters(i, 1).Font
    If ChkiFont.Color <> 0 Or _
       ChkiFont.Bold = True Or _
       ChkiFont.Italic = True Or _
       ChkiFont.Underline <> xlUnderlineStyleNone Or _
       ChkiFont.Strikethrough = True Then
      'タグのつかない部分だけ格納
      sRet = sRet & Left(sTemp, i - 1 - nDone)
      sTemp = Right(sTemp, Len(sTemp) - i + 1 + nDone)
      sAttr = ""
      With ChkiFont
      '色情報
      If .Color <> RGB(0, 0, 0) Then
        sAttr = sAttr _
        & "color: #" & Right(Application.WorksheetFunction.Rept("0", 6 - Len(Hex(.Color))) & Hex(.Color), 2) _
        & Right(Left(Application.WorksheetFunction.Rept("0", 6 - Len(Hex(.Color))) & Hex(.Color), 4), 2) _
        & Left(Application.WorksheetFunction.Rept("0", 6 - Len(Hex(.Color))) & Hex(.Color), 2) & "; "
      End If
      '太字
      If .Bold = True Then
        sAttr = sAttr & "font-weight: bold; "
      End If
      '斜体
      If .Italic = True Then
        sAttr = sAttr & "font-style: italic; "
      End If
      '下線、取消線は合わせて処理
      If .Underline <> xlUnderlineStyleNone And .Strikethrough = True Then
        sAttr = sAttr & "text-decoration: underline line-through; "
      ElseIf .Underline <> xlUnderlineStyleNone Then
        sAttr = sAttr & "text-decoration: underline; "
      ElseIf .Strikethrough = True Then
 '       sAttr = sAttr & "text-decoration: underline; "
        sAttr = sAttr & "text-decoration: line-through; "
      End If
      End With
      'spanタグを作成
      sRet = sRet & "<span style=""" & sAttr & """>"

'09/07/28　1文字のときループしてしまうケースをトラップ
      If Len(rCell.Text) = 1 Then
        GetFontInterior = sRet & sTemp & "</span>"
        Set ChkiFont = Nothing
        Exit Function
      End If

      'タグの終端を探しに行く
      For j = i + 1 To Len(rCell.Text) '同一のフォントを持たなくなる箇所＝タグの終端を特定
        Set ChkjFont = rCell.Characters(j, 1).Font
        If ChkiFont.Color <> ChkjFont.Color Or _
           ChkiFont.Bold <> ChkjFont.Bold Or _
           ChkiFont.Italic <> ChkjFont.Italic Or _
           ChkiFont.Underline <> ChkjFont.Underline Or _
           ChkiFont.Strikethrough <> ChkjFont.Strikethrough Then
        'タグを閉じる。
          sRet = sRet & Left(sTemp, j - i) & "</span>"
          sTemp = Right(sTemp, Len(sTemp) + i - j)
        '次のチェックはj文字目から
          i = j
        '戻り値にはj-1文字目まで格納
          nDone = j - 1
          Exit For
        ElseIf j = Len(rCell.Text) Then '文字列の終端までフォントが変わらない場合
          sRet = sRet & sTemp & "</span>"
          GetFontInterior = sRet
          Exit Function
        End If
      Next j
    Else
      i = i + 1
    End If
  Loop
  GetFontInterior = sRet & sTemp
End Function