横書きの半角数字を、縦表示にしても，横に「・・・」と並べるには？

質問

リンクさせたデータの中に「123（半角）」があったとして、
これを縦書きで表示させたいときに、
横に「123」と並べることはできますか？

例えて書けば・・・
「これは123円です」のデータをリンクさせて、縦書き表示にしたくて、

　こ
　れ
　は
　123
　円
　で
　す

みたいなイメージ???
１でも２でも折り返されたくなくて、３で折り返されたい感じ???
加えて、必ずしも3文字とも決まっていなくて・・・

具体的に記述して教えていただけると、ありがたいです。
かなりワガママですが、コメントを入れてください・・・
お願いします。

回答No.7

nishi6 · ベストアンサー

予想通りの指摘ですね。自分でも見苦しいかなと思っていました。

縦書きはセル単位指定のため『。、』のみを縦書きにするのは難しそうです。
『。、』のみ強制的に縦書フォントに変えてみましたが、回転できないのでうまくいきませんでした。

より自然に見えるようにしてみました。（Excelの縦書きと比べて）
『。』はなんとかごまかせている？『、』は苦しいかも知れません。現時点ではこれが最善です。
最後の方を下記のようにしてみて下さい。

　　Next
　　'『。、』を縦書き風に見せる対応
　　TateGaki = Application.Substitute(TateGaki & Right(moji, 1), "。", " " & " " & Chr(223))
　　TateGaki = Application.Substitute(TateGaki, "、", " " & "｀")
　　HankakuYokogaki = TateGaki
End Function

次に、別の考え方でマクロを作ってみました。これはExcelの縦書きと同じ表示になります。
値や式の入っているセルがA1とすると、縦に書きたいセルに=A1として表示させます。そのセルを選択したまま下記のマクロを実行します。
指定したセルから下に向かって順に文字を分割して表示します。セルの高さを操作する必要はありません。セルの結合もしません。

コピーして標準モジュールに貼り付けます。（マクロをショートカットキーを割り当てた方が楽です）
縦書きにした時に【】などを上下にしたい場合は、If InStr("　")　に全角で挿入して下さい。

Public Sub HankakuYokogaki2()
　　Dim rg As Range '縦書きにするセル
　　Dim moji As String 'セルの文字
　　Dim L As Integer 'カウンタ
　　Dim elm1, elm2, Welm As String '前後の１文字と書き出す文字
　　Dim mojiCD1, mojiCD2 As Long '前後の文字の文字コード
　　Dim kaigyo As Boolean '改行有無
　　Dim rowCot As Integer '書き出す行位置
　　Dim cutPot As Integer '書き出す文字の開始位置

　　Application.ScreenUpdating = False
　　Set rg = ActiveCell
　　moji = rg.Text & " " '前後で判定するので1文字ダミーで増やしておく
　　cutPot = 1
　　For L = 1 To Len(moji) - 1
　　　　elm1 = Mid(moji, L, 1): mojiCD1 = Asc(elm1) '調べる文字
　　　　elm2 = Mid(moji, L + 1, 1): mojiCD2 = Asc(elm2) '調べる文字の次の文字

　　　　kaigyo = True
　　　　If 48 <= mojiCD1 And mojiCD1 <= 57 Then
　　　　　　If 48 <= mojiCD2 And mojiCD2 <= 57 Then
　　　　　　　　kaigyo = False '半角数値が続いたら改行しない
　　　　　　End If
　　　　End If
　　　　　　If kaigyo = True Then '改行する場合
　　　　　　　　Welm = Mid(moji, cutPot, L - cutPot + 1)
　　　　　　　　With rg.Offset(rowCot, 0)
　　　　　　　　　　.Value = Welm
　　　　　　　　　　.HorizontalAlignment = xlCenter 'センタリング
　　　　　　　　　　.Orientation = 0 '横書きにしておく（初期値）
　　　　　　　　　　If InStr("。、ゃゅょャュョっッぁぃぅぇぉァィゥェォ（）", Welm) > 0 Then
　　　　　　　　　　　　.Orientation = xlVertical '句読点、小文字なら縦書きにする
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　　　cutPot = L + 1 '書き出す位置を進める
　　　　　　　　rowCot = rowCot + 1 '書き込む行を進める
　　　　　　End If
　　Next
　　Application.ScreenUpdating = True
End Sub

お礼

これで十分です。
本当にありがとうございました。
アナタのような方は、本当に貴重です。
また見かけたらお世話してください。