【excel】横長のコピーしているテキストを程よく改行貼付けしてくれるexcelマクロ


cutting-min概要

【マーケター、企画職、物書き、ブロガー向け】

調査や整理している時に、私はexcelにどんどんコピペしていきます。excelにそういう色んな所のWebやらpdfやwordやらのテキストを貼り付けている時に、横に長すぎてスクロールしなければ見えなかったりしますので可読性が無いです。またかと言って、手作業でF2を一々押してカーソルを移動させながら改行していたら効率が悪いです。

そこで、そういう時にこのマクロの出番です。

テキストを貼り付けた後、その貼り付けたてkしうとの一番左上のセルでこのマクロを使うとおよそ 50文字(下記で設定)で改行します。実際にはちょうど50文字毎回区切るのではなく、カンマや「」なども意識し、その周辺のぶら下がり文字をチェックしてキリの良い所で改行します。

 

そのままコピーした時(各行バラバラで右に長い) このマクロで貼り付けた時(キリの良い長さで改行を入れ、テキストで貼付ける)

 

□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□
□□□□□□□□□□□□
□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□
□□□□□□□□□□□□□□□□□
□□□□□□□□□□□□□□□□□□□□□

 

□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□
□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□
□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□
□□□□□□□□□□□□□□□□□□□□□□□□□


ぶら下がり文字の例:、。 スペース カッコなど

コード

Excelマクロざっくり設定方法

Sub fillText()

    Dim row As Integer, column As Integer
    Dim i As Integer, k As Integer, v As String
    Dim fillsize As Integer, gap As Integer, fwdgap As Integer
    Dim fs As Integer
    Dim temp As String, strPattern As String
    

    fillsize = 50  ' フィルカラムサイズ
    fwdgap = 4
    gap = fwdgap * 4 + 2 '  改行位置微調整  fillsize - fwdgap + gap の範囲でチェック
    strPattern = "[]  !),.:;?}。」、・゙゚、。,.・:;?!゛゜´ヽヾゝゞ々\-’)〕]}〉》」』】>≫]"
    

    Set RE = CreateObject("VBScript.RegExp")
    With RE
        .Pattern = strPattern       ''検索パターンを設定
        .IgnoreCase = True          ''大文字と小文字を区別しない
        .Global = True              ''文字列全体を検索
    End With
                
    row = Selection.row
    column = Selection.column
    v = Cells(row, column).Value
    i = 1
    
    Do While i < 20
        i = i + 1
        fs = fillsize
        If v = StrConv(v, vbNarrow) Then
'        If LenB(v) = LenB(StrConv(v, vbNarrow)) Then
            fs = fs + fs
        End If
        'MsgBox (i & ":" & fs & "   " & Len(v) & "<>" & LenB(v) & "<>" & LenB(StrConv(v, vbNarrow)))
        If Len(v) > fs Then
        
            '折り返し位置微調整  (、や。など)
            temp = Mid(v, fs - fwdgap, gap + fwdgap)
            Set reMatch = RE.Execute(temp)
            k = 0
            If reMatch.Count > 0 Then
               k = reMatch(0).FirstIndex - fwdgap
            End If
            
            '折り返し & 次の行へ移動
            'MsgBox i & ":[" & Mid(v, 1, fillsize + k) & "]" & vbCrLf & "[" & Mid(v, fillsize + k) & "]"
            Cells(row, column).Value = Mid(v, 1, fs + k)
            row = row + 1
            v = Mid(v, fs + k + 1) & Cells(row, column).Value
        ElseIf Selection.row + Selection.Rows.Count > row Then
            '選択範囲以内であれば、次の行も継続
            row = row + 1
            v = Cells(row, column).Value
        Else
           Exit Do
        End If
    Loop
    
    Cells(row, column).Value = v
    If i >= 20 Then
       MsgBox "terminated at " & row & ", " & column
    End If

    Set RE = Nothing
    Set reMatch = Nothing
End Sub
Delicious にシェア
Digg にシェア
reddit にシェア
LinkedIn にシェア
LINEで送る
email this
Pocket

805 views.



コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です