ExcelVBA 列の幅に収まらない文字列を下へ

質問

お世話になります。

セル書式の折り返し・縮小・結合を使用しないで、
列の幅に収まらない文字列を下の行のセルへ表示させる方法を模索しています。

Application.DisplayAlerts = False
Range("A1").Justify

で出来るらしいと書物を頼りに実施していますが、下の行のセルへ表示出来ません。

他の方法も含めて、実現方法はあるでしょうか？
よろしくお願いします。

回答No.1

cj_mover · ベストアンサー

こんにちは。

.Justify メソッド
私は、昔に少し試したぐらいで詳しいわけではないです。
今、私の環境（Win7 XL2010 64）では、正しく処理できる方法が
解らないでいます。はっきりしなくてすみません。
「単語とスペースで構成された平易な英文」
「全角文字の連続」
などでは機能するようですが、
「abcdefghijklmnopqrstuvwxyz」
「a1234567890」
などでは機能しないようです（機能させる方法が見つかりません）。
また、およそ２５５文字を超える分は無くなってしまう、そもそもの仕様のようです。

なので、とりあえず、
「折り返して全体を表示する」の動作を元にして、
"下の行のセル"へセルを分割できるものを書いてみました。
（外部オブジェクトを使う方法もありそうですが、、、。）

「折り返して全体を表示する」の仕様で、
たぶん１０２４文字を超えると正しく機能しないのでしょうけれど、
セルが文字列値であれば他に制約はないと思います。
数式（関数）を設定してあるセルを指定すると、
戻り値が文字列なら、数式を値に換えて処理します。
そもそも数式に対して折り返しもJustifyも関係ない訳ですが、
思わぬ結果にならない様に留意して、運用してください。

修正、調整に困るようでしたら、補足欄にでも書いてみてください。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' ※複数列を対象にした処理は想定（対応）しない
' ' ※サブルーチンの引数はRange型で、必ず単セル
' ' サンプルは
' ' COL = 1、　→「Ａ列の」
' ' TOPROW = 1　→「１行目から」...「有意な最下行まで」
' ' With Sheets("Sheet1")　→　「Sheet1 を対象に」
' ' 処理するように指定した例示です。

Sub Re8105487main() ' サンプル
　　Const COL = 1 ' 処理対象 列 位置 指定
　　Const TOPROW = 1 ' 先頭行 位置 指定
　　Dim i As Long

　　Application.ScreenUpdating = False
　　With Sheets("Sheet1") ' 処理対象 シート 指定
Sheet2.Cells.Copy .Cells(1)
.Range("A:B").Cut .Cells(COL)
　　　　With .Range(.Cells(TOPROW, COL), .Cells(Rows.Count, COL).End(xlUp)) ' 処理対象 範囲 指定
　　　　　　For i = .Rows.Count To TOPROW Step -1 ' 下から上へ順に処理
　　　　　　　　Call Re8105487sub(.Cells(i, COL))
　　　　　　Next i
　　　　End With
　　　　Application.ScreenUpdating = True
　　End With
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8105487sub(ByVal Target As Range)
' ' 「Targetは単一セルを指定する」「シートの保護はエラー」
' ' 呼び出し側でエラー回避すること。
　　Dim sTemp ' As String ' 対象セルの文字列
　　Dim nPrevHeight As Long
　　Dim nRegHeight As Long
　　Dim nRatio As Long
　　Dim nLength As Long
　　Dim nRowPos As Long

　　With Target
　　　　.WrapText = False ' 折り返しを「確実にキャンセル」
　　　　nPrevHeight = .Height ' 実行前の行高を取得（確保）
　　　　.EntireRow.AutoFit ' 行高を標準化（フォント依存）
　　　　nRegHeight = .Height ' 標準の行高（フォント依存）を取得
　　　　.WrapText = True ' 「折り返して全体を表示する」
　　　　nRatio = .Height / nRegHeight ' 折り返し後の行高を標準の行高で割り算して行数を求める
　　　　sTemp = .Value ' セルの値を取得
　　　　If nRatio = 1 Or TypeName(sTemp) <> "String" Then ' 行を追加する必要が無ければ
　　　　　　.WrapText = False ' 折り返しをキャンセル
　　　　　　.RowHeight = nPrevHeight ' 行高を実行前に戻す
　　　　　　Exit Sub ' サブルーチンを抜ける
　　　　End If
　　　　.Offset(1).Resize(nRatio - 1).EntireRow.Insert ' 必要な行数だけ行挿入
　　　　nLength = Len(sTemp) ' 文字長を取得
　　　　For nRowPos = nRatio To 2 Step -1 ' 挿入した行を下から上にループ
　　　　　　Do
　　　　　　　　nLength = nLength - 1 ' 文字長を減らす
　　　　　　　　.Value = Left$(sTemp, nLength) ' セル値を一文字ずつ短くする
　　　　　　Loop Until CLng(.Height / nRegHeight) < nRowPos ' セルの折り返しによる行高が小さくなったら
　　　　　　.Cells(nRowPos, 1).Value = Mid$(sTemp, nLength + 1) ' 後方の文字列を挿入した行のセルに出力
　　　　　　sTemp = Left$(sTemp, nLength) ' 未出力の文字列
　　　　Next nRowPos
　　　　With .Resize(nRatio)
　　　　　　.WrapText = False ' 折り返しをキャンセル
　　　　　　.RowHeight = nPrevHeight ' 行高を実行前のものに統一
'　　　　　　Target.Copy
'　　　　　　.PasteSpecial xlPasteFormats
'　　　　　　Application.CutCopyMode = False
　　　　End With
　　End With
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

お礼

ご丁寧に、プログラム付きでありがとうございます。
全てを理解するのは無理ですが、一部は取り入れられると思います。
さっそく応用してみます。

回答No.2

cj_mover

あ、すみません。
編集ミス、消し忘れがありました。

> Sheet2.Cells.Copy .Cells(1)
> .Range("A:B").Cut .Cells(COL)

上記２行は、こちらでのテスト用の記述ですので、
削除して投稿するべきものでした。
上記２行、削除してください。

失礼しました。