文字を180度回転したい

Question

エクセルで将棋盤を再現したいと思い、VBAを１から学び始め１週間です。
SFEN形式というものを変換し、盤面を再現したいです。

例）
lnG4nl/5k3/p1p+R1g1p1/1p1p3sp/5N3/2P1p1p2/PP1GP3P/1SG2+p1+b1/LN1K4L/w/Srbs4p/60

【実現したいこと】
後手番となる相手の駒（先に”歩”や”金”などに変換したもの）を180度回転させて表示したいです。
よろしくお願いいたします。

コードを書き始めたばかりでとても見にくい物になっているかと思います。
書き方などもご教授いただけたら幸いです。

該当のソースコード

Sub 空欄をスラッシュに変換()
    Worksheets("SFEN").Range("A1").Replace " ", "/", xlPart
End Sub

Sub スラッシュで分ける()
    Dim a, i As Variant
    Dim j As Long
   
    With ActiveSheet
        'コンマ区切りで分割
        a = Split(Worksheets("SFEN").Cells(1, 1), "/")
        '配列の大きさの分だけループ
        For i = 0 To UBound(a)
            Worksheets("Sheet2").Cells(1, 1 + i) = a(i) 'セルへ入力
        Next
    End With
End Sub
Sub 駒に変換()
           
    Worksheets("Sheet2").Range("A1:L1").Replace "+s", "全", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "+p", "と", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "+n", "圭", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "+l", "杏", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "+b", "馬", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "+r", "竜", xlPart, MatchCase:=True
    
    Worksheets("Sheet2").Range("A1:L1").Replace "s", "銀", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "p", "歩", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "n", "桂", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "l", "香", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "b", "角", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "r", "飛", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "k", "王", xlPart, MatchCase:=True
    Worksheets("Sheet2").Range("A1:L1").Replace "g", "金", xlPart, MatchCase:=True
         
End Sub

Sub 横を縦に変換()
    Dim i As Long, j As Long
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
    Set Ws1 = Worksheets("Sheet2")
    Set Ws2 = Worksheets("将棋盤")
        For i = 1 To Ws1.Cells(Rows.Count, 1).End(xlUp).Row
        For j = 1 To 9
            Ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1) _
            .Value = Ws1.Cells(i, j).Value
        Next j
    Next i
Set Ws1 = Nothing: Set Ws2 = Nothing
End Sub

Sub 一文字ずつ区切る()
    Dim str As String
    Dim i As Long
    Dim j As Long
        
    Worksheets("将棋盤").Activate
 ' セルB2を選択状態にする
    For j = 2 To 10
    Worksheets("将棋盤").Cells(j, 1).Select
     
        With ActiveCell
        str = .Value
        For i = 1 To Len(str)
        .Offset(0, i).Value = Mid(str, i, 1)
'offset セルの移動
'Mid("文字",文字の何番目,抜き出す文字数)
      Next i
    End With
  Next j
 
End Sub

Sub 後手の回転(sheetName As String, targetStr As String, font As Long)

    Dim targetStrLen As Integer
    Dim r As Range
    Dim index As Double
    Dim fontObj As font
    
    
    targetStrLen = Len(targetStr)
    
    For Each r In Worksheets("将棋盤").UsedRange
    
        index = 1
        
        Do
            index = InStr(index, r.Value, targetStr)
        
            If (index <> 0) Then
                Set fontObj = r.Characters(index, targetStrLen).font
                With fontObj
                    .color = color '色を変更
                    .Bold = True   '太くする　　←この部分も変えたい　＠游ゴシックに変更→９０度回転
                End With
                index = index + targetStrLen
            Else
                Exit Do
            End If

        Loop
        
    Next

    Set fontObj = Nothing

End Sub

試したこと

文字を検索し、該当の文字だけ色を変えるというコードがあったので、それをもとに改良してみたのですが、うまく作動しませんでした。

よろしくお願いいたします。

Answer 1

Function 回転(c As Range)
    c.Orientation = 90
    c.Font.Name = "@游ゴシック"
End Function

---

後手の駒だけ漢字変換済みなら

Function 後手反転(盤 As Range)
    Dim c As Range
    For Each c In 盤
        Select Case c.Value
        Case "全", "と", "圭", "杏", "馬", "竜", "銀", "歩", "桂", "香", "角", "飛", "王", "金"
            c.Orientation = 90
            c.Font.Name = "@游ゴシック"
        Case Else
            c.Orientation = 0
            c.Font.Name = "游ゴシック"
        End Select
    Next
End Function

漢字に変換する前に書式設定するなら

Function 後手反転(盤 As Range)
    Dim c As Range
    For Each c In 盤
        If c.Value = UCase(c.Value) Then
            '大文字なら先手
            c.Orientation = 0
            c.Font.Name = "游ゴシック"
        Else
            '小文字なら後手
            c.Orientation = 90
            c.Font.Name = "@游ゴシック"
        End If
    Next
End Function

Comments

[ninngin]

ありがとうございます。function　を使うとよいのですね！
これを、セルの中に歩、金、飛、角などの文字が入っている場合のみ実行するプログラムを書きたいです。if分などを検索してみたのですが、なかなかうまくいきません。

[jinoji]

たとえば
Worksheets("将棋盤").Range("B2").Resize(9, 9).SpecialCells(xlCellTypeConstants)
とかすれば、文字が入っているセルを一括で指定できますが、
先手の駒か後手の駒かを見分けるのはどうしますか？

[ninngin]

先に後手のみ日本語に変換しているので、”歩”、”金”、”王”など、一つずつ指定していけば上手くいくかなと考えていました。
そのあとWorksheets("将棋盤")で残っている大文字を変換できたらよいかなと思っていました。
そんな方法はないでしょうか、、、

[ninngin]

ありがとうございます

Sub 後手の駒の回転()
Call 後手反転(Worksheets("Sheet2").Range("A1:L1"))
End Sub

で実行しようとしたのですが、反映されません。
書き方が違うでしょうか？
何度も申し訳ないです。

Answer 2

文字を回転させる方法は分かりません。

図形でしたら回転できますね。

どこかのセルに各駒を表示しておいて
セル単位に「図形としてコピー」し目的のセルに貼り付けてはいかが。
もちょっとカッコつけて駒のイラストを貼り付けるってのもありかも。

Comments

[ninngin]

回答ありがとうございます。画像という方法もあるのですね！まったく考えませんでした。
jinoji様が回答くださったように、フォント名の前に＠をつけ、それから９０度回転させると、１８０度回転となるようです。
その方法をもう少し探り、無理そうなら画像でチャレンジしてみたいと思います