Excelで「折り返して全体を表示」状態のセルの文字列を表示されたまま改行が入った状態で取得する試み（挫折）

0.README.md

[Excel] 「折り返して全体を表示」状態のセルの文字列を表示のまま（改行が入った状態）で取得する試み（挫折）

元ネタ

• fishb@dampenedkidさんのツイート
• VBA Win32APIを使って、文字列の実描画幅を取得する。 - t-hom’s diary
• 【VBA】文字列をいい感じに改行してみる - 無限不可能性ドライブ

ソースコード

1. 画像使用版（挫折）
2. 文字の割付版（とりあえず動作）
3. いい感じに改行Ex（絵文字対応版） ※【VBA】文字列をいい感じに改行してみる - 無限不可能性ドライブの改訂版

GetLineBreakText.vba

Option Explicit

' 元ネタ： [VBA Win32APIを使って、文字列の実描画幅を取得する。 - t-hom’s diary](https://thom.hateblo.jp/entry/2019/01/19/020840)

Function GetLineBreakText(ByRef TargetCell As Range, Optional TemporarySheet As Worksheet) As String
    Dim SavedScreenUpdate As Boolean: SavedScreenUpdate = Application.ScreenUpdating
    Dim SavedDisplayAlerts As Boolean:  SavedDisplayAlerts = Application.DisplayAlerts
    Dim SheetIsCreated As Boolean: SheetIsCreated = IIf(TemporarySheet Is Nothing, True, False)
    Dim TextMatrix As Variant
    Dim TextList() As String
    Dim CurrentCell As Range
    Dim Index As Long
    Dim ResultText As String: ResultText = ""
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    If SheetIsCreated Then Set TemporarySheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    TemporarySheet.Cells.Clear
        
    TextList = Split(TargetCell.text, vbLf) ' 元セルに改行がある場合、文字の割付が期待通りにならないため、改行で分割
    
    If 0 < UBound(TextList) - LBound(TextList) + 1 Then
        With TemporarySheet.Range("A1").Resize(1, UBound(TextList) - LBound(TextList) + 1)
            .Value = TextList
            
            TargetCell.Copy
'            .EntireColumn.PasteSpecial Paste:=xlPasteFormats
'            .EntireColumn.PasteSpecial Paste:=xlPasteColumnWidths
            TemporarySheet.Cells.PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteColumnWidths
            
            For Each CurrentCell In .Cells
                CurrentCell.Justify ' ホーム→編集→フィル→文字の割付
                With TemporarySheet
                    TextMatrix = .Range(CurrentCell, .Cells(.Rows.Count, CurrentCell.Column).End(xlUp))
                End With
                
                If IsArray(TextMatrix) Then
                    For Index = LBound(TextMatrix) To UBound(TextMatrix)
                        ResultText = ResultText & CStr(TextMatrix(Index, UBound(TextMatrix, 2))) & vbLf
                    Next
                Else
                    ResultText = ResultText & CStr(TextMatrix) & vbLf
                End If
            Next
        End With
    End If
    If SheetIsCreated Then TemporarySheet.Delete
    
    If ResultText <> "" Then ResultText = Left(ResultText, Len(ResultText) - Len(vbLf)) ' 最後の LF を削除
    GetLineBreakText = ResultText

    Application.DisplayAlerts = SavedDisplayAlerts
    Application.ScreenUpdating = SavedScreenUpdate
End Function

Sub Test_JustifyVer()
    Application.ScreenUpdating = False
    
    Dim TargetCell As Range
    Dim CurrentSheet As Worksheet: Set CurrentSheet = ActiveSheet
    Dim TemporarySheet As Worksheet
    Set TemporarySheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    With CurrentSheet
        .Select
        
        With .Range("A:A")
            .WrapText = True ' 折り返して全体を表示
            .Rows.AutoFit ' 行の高さを調整
        End With
        
        .Range("B:B").ClearContents
        
        ' A 列の文字列を見た目通りに改行を入れた後 B 列にコピー
        For Each TargetCell In .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp))
            TargetCell.Offset(0, 1) = GetLineBreakText(TargetCell, TemporarySheet)
        Next
    
        .Range("B1").Select
    End With
    
    Application.DisplayAlerts = False
    TemporarySheet.Delete
    Application.DisplayAlerts = True

    Application.ScreenUpdating = True
End Sub

GetLineBreakText_PicVer.vba

Option Explicit

' 元ネタ： [VBA Win32APIを使って、文字列の実描画幅を取得する。 - t-hom’s diary](https://thom.hateblo.jp/entry/2019/01/19/020840)

Function GetLineBreakText_PicVer(ByRef TargetCell As Range, Optional MaxRetry As Long = 3) As String
    Dim SavedScreenUpdate As Boolean: SavedScreenUpdate = Application.ScreenUpdating
    Dim ResultText As String: ResultText = ""
    Dim TextShape As Shape
    Dim Counter As Long
    Dim LineNumber As Long: LineNumber = 0
    Dim LastTop As Double: LastTop = 0
    Dim LineHeight As Double: LineHeight = 0
    
    Application.ScreenUpdating = False
    
    With TargetCell.Worksheet
        ' コピーもしくはペーストが失敗する現象への対策
        On Error GoTo RETRY_COPY
        Counter = 1
        Do
COPY_LOOP:
            ' 指定 Range を Picture としてコピー＆ペースト
            TargetCell.CopyPicture
            .Paste
            Exit Do
RETRY_COPY:
            Counter = Counter + 1
            If Err.Number <> 1004 Or 1 + MaxRetry < Counter Then
                Error Err.Number
                Exit Function
            End If
            
            ' Debug.Print " Error in " & TargetCell.Address & ": " & CStr(Err.Number) & " " & Err.Description
            DoEvents
            Resume COPY_LOOP
        Loop While True
        On Error GoTo 0
        
        With .Shapes(.Shapes.Count)
            ' 取得した Picture を Microsoft Office 描画オブジェクトに変換
            .Ungroup
        End With
        
        With .Shapes(.Shapes.Count) ' ※いったん Ungroup してしまったものは、元の Picture とは異なるオブジェクトとなる
            ' 図形が持つテキスト同士を改行で結合
            For Each TextShape In .GroupItems
                With TextShape
                    If .TextFrame2.HasText Then
                        If 0 < LastTop Then
                            ' 空白行が図形化されない現象への対策
                            If LineHeight = 0 Then
                                If (.Top - LastTop) <= .Height Then LineHeight = .Top - LastTop
                            End If
                            
                            For Counter = 2 To WorksheetFunction.RoundUp((.Top - LastTop) / IIf(0 < LineHeight, LineHeight, .Height), 0)
                                ResultText = ResultText & vbLf
                                LineNumber = LineNumber + 1
                            Next
                        End If
                        ResultText = ResultText & .TextFrame2.TextRange.text & vbLf
                        LineNumber = LineNumber + 1
                        LastTop = .Top
                    End If
                End With
            Next
            .Delete
        End With
    End With
    
    If 0 < LineNumber Then ResultText = Left(ResultText, Len(ResultText) - Len(vbLf)) ' 最後の改行を削除
    
    GetLineBreakText_PicVer = ResultText
    
    Application.ScreenUpdating = SavedScreenUpdate
End Function

Sub Test_PicVer()
    Dim TargetCell As Range
    
    Application.ScreenUpdating = False
    
    With Range("A:A")
        .WrapText = True ' 折り返して全体を表示
        .Rows.AutoFit ' 行の高さを調整
    End With
    
    Range("B:B").ClearContents
    
    ' A 列の文字列を見た目通りに改行を入れた後 B 列にコピー
    For Each TargetCell In Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp))
        TargetCell.Offset(0, 1) = GetLineBreakText_PicVer(TargetCell)
    Next
    
    Range("B1").Select
    
    Application.ScreenUpdating = True
End Sub

いい感じに改行Ex.vba

Option Explicit

' オリジナル：[【VBA】文字列をいい感じに改行してみる - 無限不可能性ドライブ](https://celaeno42.hatenablog.com/entry/2019/01/20/000554)

'メインのエントリポイントです。このプロシージャから実行してください。
Public Sub Main()
    Dim r As Long
    '一行あたりのバイト数（全角文字×2を指定のこと:全角10文字ごとに改行したい場合は20を指定）
    Const MAX_BYTE As Long = 20
    
    'A2～A5に対象の文字列を入力した状態で実行してください。
    '結果はB2～B5セルに出力されます。
    For r = 2 To 5
        Cells(r, 2).Value = いい感じに改行Ex(Cells(r, 1).Value, MAX_BYTE)
    Next
    
End Sub

'なるべく一行が揃うように改行します。
'[引数] <- aStr : String / 対象の文字列, aMaxByte : Long / 一行あたりのバイト数
'[戻り値] -> String / 改行された文字列
Private Function いい感じに改行Ex(ByRef aStr As String, ByRef aMaxByte As Long) As String
    Dim res As String
    Dim char1 As String
    Dim pos As Long
    Dim byteCount As Long
    Dim strLine As String
    Dim byteBuffer() As Byte
    Dim charCode As Long
    Dim suffix As String

    '文字列を1文字(2バイト)ずつ取り出しつつ長さを計っていく
    byteBuffer = aStr
    res = ""
    strLine = ""
    byteCount = 0
    For pos = LBound(byteBuffer) To UBound(byteBuffer) Step 2
        charCode = CLng(byteBuffer(pos + 1)) * 256 + byteBuffer(pos)
        char1 = ChrW(charCode)
        strLine = strLine & char1
        suffix = vbLf
        
        Select Case charCode
            Case &HD800& To &HDBFF& ' 上位サロゲート
                ' カウントしない
            Case &HDC00& To &HDFFF& ' 下位サロゲート
                byteCount = byteCount + 2
            Case Else
                Select Case char1
                    Case vbCr
                        ' カウントしない
                    Case vbLf
                        ' 元々の改行はそのまま保持
                        byteCount = aMaxByte
                        suffix = ""
                    Case Else
                        ' VBのLenBの仕様上の都合により、StrConvで変換の上カウント
                        byteCount = byteCount + LenB(StrConv(char1, vbFromUnicode))
                End Select
        End Select
        
        If byteCount >= (aMaxByte - 1) Then
            res = res & strLine & suffix
            strLine = ""
            byteCount = 0
        End If
    Next
    
    '最後に残った部分を追加
    res = res & strLine
    
    '末尾に改行がある場合は削除
    If Right(res, Len(vbLf)) = vbLf Then
        res = Left(res, Len(res) - Len(vbLf))
    End If
    
    いい感じに改行Ex = res
     
End Function

■ Excel で、「折り返して全体を表示する」状態にしたセルについて、画面上に表示されているままに（改行が入った）文字列を取得する試み

• 画像使用版（挫折）
• 文字の割付版（とりあえず動作）
• いい感じに改行Ex（絵文字対応版）

■ 元ネタ

• fishb@dampenedkidさんのツイート
• VBA Win32APIを使って、文字列の実描画幅を取得する。 - t-hom’s diary
• 【VBA】文字列をいい感じに改行してみる - 無限不可能性ドライブ

画像使用版の実装案としては、いったんセルの内容を画像としてコピーしたものを貼り付け、これを図形化（Microsoft Office 描画オブジェクトに変換）後、テキストが含まれている Shape を抽出して改行で連結する、というもの。

やってみたら下記のような問題があるため、挫折。

• 実行速度が遅い
• 空白行の変換がうまくいかない
• Range.CopyPicture や Worksheet.Paste が結構な頻度で失敗する
• 文字がたまに化けている

画像使用版に於いて、Range.CopyPicture や Worksheet.Paste が結構な頻度で 1004 エラーになるのはなんでだろう……？

試していると、

• 「Range クラスの CopyPicture メソッドが失敗しました。」
• 「アプリケーション定義またはオブジェクト定義のエラーです。」
• 「データを貼り付けできません。」
• 「クリップボードを空にできません。別のアプリケーションがクリップボードを使用している可能性があります。」

といったエラーが出てしまう。

文字の割付版は、エクセルのホーム→編集→フィル→文字の割付の機能を利用したもの

以下の様な問題はあるものの、一応動作する模様

• 実行速度が遅い（画像使用版よりは若干まし？）
• URLやソースコードなどでの半角英数記号が連続して続くようなもの等はうまく改行されない
• 行頭にスペースがある場合は詰められてしまう

【VBA】文字列をいい感じに改行してみる - 無限不可能性ドライブ
おーなるほど、本来のfishb@dampenedkidさんのツイートの主旨なら（可変幅フォントのときのガタガタを気にしないなら）これで十分なのか。

絵文字（サロゲートペア）が含まれる場合と、元々改行が入っている場合にちょっと気になったので、改修してみた→いい感じに改行Ex（絵文字対応版）。