カテゴリー: Excel VBA

売上データなど、Excelで作った表を送る場合に、メールやチャットにてテキスト形式で送りたいことがあると思います。
そんなExcel表からテキストへ変換するためのプログラムを作成してみました。

私はシステムエンジニアなので、プログラムのコメントでテキスト形式の表を書いたりします。

今回は、範囲選択した中のデータをテキスト形式の表にし、クリップボードにコピーします。(メモ帳等に張り付けてご利用ください)
なお、セルの書式設定が通貨(#,##0)の場合のみ三桁カンマを付与し、値が数値の場合は右寄せ、それ以外は左寄せで表を作成します。

ConvertExcelTableText

1 file(s) 22.45 KB

エクセルファイルをダウンロード

このエクセルファイルの作り方

①マクロを使えるようにする
「マクロを使えるようにする」を参照

②ボタンを配置する
　※ ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

③ボタン配置時の以下の画面で「マクロ名」を「ConvertTable 」として「新規作成」を押す

④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub ConvertTable()
    Dim result As String
    Dim startRow, startCol, endRow, endCol As Integer
    Dim selectArea As Range
    Set selectArea = Selection
    
    startRow = selectArea.Cells(1).Row
    startCol = selectArea.Cells(1).Column
    endRow = selectArea.Cells(selectArea.Count).Row
    endCol = selectArea.Cells(selectArea.Count).Column
    
    Dim widthDic As Object
    Set widthDic = CreateObject("Scripting.Dictionary")
    
    Dim maxWidth As Integer: maxWidth = 0
    
    Dim cellVal As String
    Dim margin As Integer
    
    
    ' 各列毎の最大幅を配列で保持
    For j = startCol To endCol Step 1
        For i = startRow To endRow Step 1
            cellVal = Cells(i, j).Value
            If IsNumeric(cellVal) And Cells(i, j).NumberFormatLocal = "#,##0" Then
                cellVal = Format(cellVal, "#,#")
            End If
            
            If maxWidth < LenB(StrConv(cellVal, vbFromUnicode)) Then
                maxWidth = LenB(StrConv(cellVal, vbFromUnicode))
            End If
        Next
        widthDic.Add j, maxWidth
        maxWidth = 0
    Next
    
    ' 表文字列の作成
    For i = startRow To endRow Step 1
        ' 線だけの行を書き込み
        For j = startCol To endCol Step 1
            If i = startRow Then
                If j = startCol Then
                    result = result &amp; "┌"
                Else
                    result = result &amp; "┬"
                End If
            Else
                If j = startCol Then
                    result = result &amp; "├"
                Else
                    result = result &amp; "┼"
                End If
            End If
            
            result = result &amp; String(Application.WorksheetFunction.RoundUp(widthDic.Item(j) / 2, 0), "─")
            
            If i = startRow And j = endCol Then
                result = result &amp; "┐"
            ElseIf i <> startRow And j = endCol Then
                result = result &amp; "┤"
            End If
        Next
        result = result &amp; vbCrLf
        ' 値の行を書き込み
        For j = startCol To endCol Step 1
            result = result &amp; "│"
            cellVal = Cells(i, j).Value
            If IsNumeric(cellVal) And Cells(i, j).NumberFormatLocal = "#,##0" Then
                cellVal = Format(cellVal, "#,#")
            End If
            
            margin = widthDic.Item(j) - LenB(StrConv(cellVal, vbFromUnicode))
            margin = margin + widthDic.Item(j) Mod 2
            
            If IsNumeric(cellVal) Then
                result = result &amp; Space(margin)
                result = result &amp; cellVal
            Else
                result = result &amp; cellVal
                result = result &amp; Space(margin)
            End If
            
            If j = endCol Then
                result = result &amp; "│"
            End If
        Next
        result = result &amp; vbCrLf
    Next
    
    ' 最下部の線を書き込み
    For j = startCol To endCol Step 1
        If j = startCol Then
            result = result &amp; "└"
        Else
            result = result &amp; "┴"
        End If
        
        result = result &amp; String(Application.WorksheetFunction.RoundUp(widthDic.Item(j) / 2, 0), "─")

        If j = endCol Then
            result = result &amp; "┘"
        End If
    Next
    
    '表文字列をクリップボードに格納する
    With New MSForms.DataObject
        .SetText result
        .PutInClipboard
    End With
End Sub

⑤ 「C:\Windows\System32\FM20.DLL」を参照する
※クリップボードに値を格納するためのアセンブリ
※ない場合は 「C:\Windows\SysWOW64\FM20.DLL」