「今さら」なんてない

「自分にもできそう」を伝播させるブログ

対神エクセル!指定文字数で改行し直してペーストする

方眼紙エクセルフォーマットで無駄な作業の代表格の一つとして、改行位置の修正があると思うのですが これもサクッとやっちまいたくて作りました。 (非対応の形もあり、完成形ではありませんが)


概要

  • 選択範囲を一度まとめてから、指定文字数ごとに改行し直す
  • 出力は1行1セル
  • 既存の改行位置はそのまま改行位置として残す
    ※ただし改行コードではない改行位置(セル区切り)については非対応
  • 2列以上選択した場合も出力は1列
    (2列以上選択されている場合は実行可否のポップアップが出る)


コピペするコード

Sub 文字数ごとに改行()
    Dim rCell, i, k
    Dim str, strArr() As Variant
    Dim 指定文字数, 開始位置, 既存改行位置
    Dim iniRows, iniColumns
    Dim rc
    
    指定文字数 = InputBox("1行あたりの文字数を入力してください" & vbCrLf & _
        "指定文字数の位置で改行します。", "改行位置設定")
    
    If IsNumeric(指定文字数) = False Then: Exit Sub
    If 指定文字数 < 1 Then: Exit Sub
    
   
    '複数列が選択されていたら警告(実行したい時もあるだろうから実行の余地も残しておく)
        If iniColumns > 1 Then
            rc = MsgBox("複数列まとめて1列に出力されます。" & vbCrLf & _
                "※選択範囲から飛び出た場合、セルが上書きされます。" & vbCrLf & vbCrLf & _
                "選択し直しますか?" & vbCrLf & _
                "「いいえ」を押すと実行します。", _
                vbYesNo + vbExclamation, "注意:2列以上選択されています")
                
            If rc = vbYes Then
                MsgBox "処理を中止します"
                Exit Sub
            End If
        End If
        
    '初期化
        開始位置 = 1
        k = 0
        iniRows = Selection.Rows.Count
        iniColumns = Selection.Columns.Count
    
    '範囲内の文字列をすべて1つの変数に格納する
        For Each rCell In Selection
            str = str & rCell.Value
        Next rCell
    
    '指定文字数ごとに改行コードを入れる
        Do While Len(str) >= 開始位置
            ReDim Preserve strArr(k)
            
                '既存の改行コードが出てきたらすぐ分割
                既存改行位置 = InStr(Mid(str, 開始位置, 指定文字数), vbLf)
                
                If 既存改行位置 > 0 Then
                    strArr(k) = Mid(str, 開始位置, 既存改行位置)
                    開始位置 = 開始位置 + 既存改行位置
                    
                Else
                '改行コードがなければ指定文字数ごとに改行コードを入れる
                    strArr(k) = Mid(str, 開始位置, 指定文字数)
                    開始位置 = 開始位置 + 指定文字数
                
                End If
            k = k + 1
        Loop
        
    '出力
        For i = 0 To k - 1
            Selection(1).Offset(i, 0).Value = strArr(i)
        Next i
        
    '行数が減る場合は、余った範囲を削除する(k+1行目からiniRows)
        If k < iniRows Then
            For i = k To iniRows
                Selection(1).Offset(i, 0) = ""
            Next i
        End If
        '複数列をまとめた場合も2列目以降を削除する
        If iniColumns > 1 Then
            Selection(1).Offset(0, 1).Resize(iniRows, iniColumns).Value = ""
        End If
        
End Sub

コードの解説

冒頭:改行位置(文字数)指定

まずはInputBoxで数値を入力します。

指定文字数 = InputBox("1行あたりの文字数を入力してください" & vbCrLf & _
        "指定文字数の位置で改行します。", "改行位置設定")

入力データが数値でなかったり
1未満だったら処理しないようにします。


If IsNumeric(指定文字数) = False Then: Exit Sub
    If 指定文字数 < 1 Then: Exit Sub

実行可否の確認(2列以上選択時)

        If iniColumns > 1 Then
            rc = MsgBox("複数列まとめて1列に出力されます。" & vbCrLf & _
                "※選択範囲から飛び出た場合、セルが上書きされます。" & vbCrLf & vbCrLf & _
                "選択し直しますか?" & vbCrLf & _
                "「いいえ」を押すと実行します。", _
                vbYesNo + vbExclamation, "注意:2列以上選択されています")
                
            If rc = vbYes Then
                MsgBox "処理を中止します"
                Exit Sub
            End If
        End If

MsgBoxの戻り値(YesかNoか)をrcという変数に格納しておいて、Yesなら実行しないようにする部分です。(連打して誤作動を起こすかもなのでNoを実行トリガにしました)


前処理:範囲内の文字列を1つの変数にまとめる

        For Each rCell In Selection
            str = str & rCell.Value
        Next rCell

とりあえずまとめる系(プレフィックスサフィックス)の処理は元の値=元の値 & 追加分ラクです。


指定文字数ごとに改行コードを入れる

 Do While Len(str) >= 開始位置
    ReDim Preserve strArr(k)
            
        '既存の改行コードが出てきたらすぐ分割
        既存改行位置 = InStr(Mid(str, 開始位置, 指定文字数), vbLf)
                
        If 既存改行位置 > 0 Then
            strArr(k) = Mid(str, 開始位置, 既存改行位置)
            開始位置 = 開始位置 + 既存改行位置
                    
        Else
        '改行コードがなければ指定文字数ごとに改行コードを入れる
            strArr(k) = Mid(str, 開始位置, 指定文字数)
            開始位置 = 開始位置 + 指定文字数
                
        End If
    k = k + 1
Loop

流れとしては

  1. 改行予定の文字数以内に、既存の改行がないか確認
  2. あればそこで配列に分割して格納する
  3. なければ指定文字数の位置で分割する

このとき、次の行のMidの開始位置を更新しておいてあげます。


改行して出力

For i = 0 To k - 1
    Selection(1).Offset(i, 0).Value = strArr(i)
Next i

あとは簡単。配列を順番にセルに出力するだけ。

For文なしでResizeして1発で貼り付けるやり方もあるみたいですが、まだ血肉になってないのでとりあえずこのやり方にしました。


行数が減る場合は、余った範囲を削除する

If k < iniRows Then
    For i = k To iniRows
        Selection(1).Offset(i, 0) = ""
    Next i
End If

'複数列をまとめた場合も2列目以降を削除する
If iniColumns > 1 Then
    Selection(1).Offset(0, 1).Resize(iniRows, iniColumns).Value = ""
End If

これがないとはみ出た部分に文字が残ったままで汚いので掃除します。


残課題:改行コードではない既存の改行位置は未完成

セル内の改行(vbLf)による改行には対応しているのですが、
現状、編集前の状態が

編集前
1行目ぇぇぇえええ
2行目ぇええ
3行目

こんなのだとしたら

5文字で改行すると

編集後
1行目ぇぇ
ぇえええ2
行目ぇええ
3行目

となってしまいます。

本来やりたい姿
1行目ぇぇ
ぇえええ
2行目ぇえ
3行目

こうするにはどうすれば良いんですかね?

指定文字数未満を条件に為た場合、例えば1行10文字のものを15文字に拡張することができなくなります。

んー。意外と闇が深い...
そもそもこんなフォーマットでしがらみを作るなよ...