'表をテキストに変換するマクロ

'セル範囲を選択してTableToText3マクロを実行してください。

Option Explicit

Sub TableToText3()
    Const myTitle = "表をテキストに変換"

    Dim range1 As Range
    Dim iColCount As Integer, iRowCount As Integer
    Dim iRowNoWidth As Integer, iSpace As Integer
    Dim i As Long, j As Long, k As Long, n As Long
    Dim sOut As String, CRLF As String, sVBorder As String
    Dim s As String
    Dim bOutputFormula As Boolean
    Dim iColWidth() As Integer
    Dim sHeader() As String
    Dim iAlign() As Integer
    Dim sText() As String

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択して実行してください。", vbExclamation, myTitle
        Exit Sub
    End If

    '数式出力の問い合わせ
    If MsgBox("数式を出力しますか？", vbYesNo + vbQuestion, myTitle) = vbYes Then
        bOutputFormula = True
    Else
        bOutputFormula = False
    End If

    '列区切り空白
    sVBorder = Space(2)

    '行番号の桁数
    iRowNoWidth = 2

    Set range1 = Selection.Areas(1)
    iColCount = range1.Columns.Count
    iRowCount = range1.Rows.Count

    ReDim iColWidth(1 To iColCount)
    ReDim sHeader(1 To iColCount)
    ReDim sText(1 To iRowCount, 1 To iColCount)
    ReDim iAlign(1 To iRowCount, 1 To iColCount)

    sOut = ""
    CRLF = Chr$(13) & Chr$(10)

    'セル値の文字列を作成
    For i = 1 To iRowCount
        For j = 1 To iColCount
            With range1.Cells(i, j)
                If Not IsEmpty(.Value) Then
                    If .HasFormula And bOutputFormula Then
                        iAlign(i, j) = xlLeft
                        sText(i, j) = .FormulaLocal
                    Else
                        If .HorizontalAlignment = xlGeneral Then
                            Select Case VarType(.Value)
                                Case vbString
                                    iAlign(i, j) = xlLeft
                                Case vbBoolean, vbError
                                    iAlign(i, j) = xlCenter
                                Case Else
                                    iAlign(i, j) = xlRight
                            End Select
                        End If
                        sText(i, j) = .Text
                    End If
                End If
            End With
        Next
    Next

    '1行目の文字列の作成
    For j = 1 To iColCount
        sHeader(j) = ColumnToA1(range1.Columns(j).Column)
    Next

    '列の最大バイト数を取得
    For j = 1 To iColCount
        n = myLenB(sHeader(j))
        For i = 1 To iRowCount
            k = myLenB(sText(i, j))
            If k > n Then n = k
        Next
        iColWidth(j) = n
    Next

    '1行目の出力
    s = Space(iRowNoWidth)
    For j = 1 To iColCount
        s = s & sVBorder & _
            myLeftB(Space((iColWidth(j) - myLenB(sHeader(j))) \ 2) _
            & sHeader(j) & Space(iColWidth(j)), CLng(iColWidth(j)))
    Next
    sOut = sOut & RTrim$(s) & CRLF

    '2行目以降の文字列の出力
    For i = 1 To iRowCount
        s = Format$(range1.Rows(i).Row, String(iRowNoWidth, "@"))
        For j = 1 To iColCount
            '空白のバイト数を取得
            iSpace = iColWidth(j) - myLenB(sText(i, j))
            Select Case iAlign(i, j)
                Case xlRight
                    s = s & sVBorder & Space(iSpace) & sText(i, j)
                Case xlLeft
                    s = s & sVBorder & sText(i, j) & Space(iSpace)
                Case Else
                    s = s & sVBorder & _
                        myLeftB(Space(iSpace \ 2) & sText(i, j) _
                        & Space(iSpace), CLng(iColWidth(j)))
            End Select
        Next
        sOut = sOut & RTrim$(s) & CRLF
    Next

    '文字列をコピーしてメモ帳に貼り付ける
    With Workbooks.Add(xlWorksheet)
        With .Worksheets(1)
            .Cells.Clear
            i = TextToRange(.Cells(1, 1), sOut, CRLF)
            If i > 0 Then
                .Cells(1, 1).Resize(i, 1).Copy
                i = Shell("notepad.exe", 1)
                SendKeys "^v"
            End If
        End With
        .Close False
    End With
End Sub


'文字列を区切り文字で分割してセルに書き出す関数
Function TextToRange(range1 As Range, sText As String, _
        sSeparator As String) As Long
    Dim iStart As Long, iNext As Long, iLength As Long, iRow As Long
    Dim iSeparatorLength As Long

    iLength = Len(sText)
    iSeparatorLength = Len(sSeparator)
    iRow = 0
    iStart = 1
    Do While iStart <= iLength
        iNext = InStr(iStart, sText, sSeparator, 0)
        If iNext = 0 Then
            iRow = iRow + 1
            range1.Cells(iRow, 1).Value = "'" & Mid$(sText, iStart)
            Exit Do
        Else
            iRow = iRow + 1
            range1.Cells(iRow, 1).Value _
                = "'" & Mid$(sText, iStart, iNext - iStart)
            iStart = iNext + iSeparatorLength
        End If
    Loop
    TextToRange = iRow
End Function

'列番号をA1形式に変換する関数
Function ColumnToA1(columnNo As Integer) As String
    If columnNo > 26 Then
        ColumnToA1 = Chr$(64 + (columnNo - 1) \ 26) _
            & Chr$(65 + (columnNo - 1) Mod 26)
    Else
        ColumnToA1 = Chr$(65 + (columnNo - 1) Mod 26)
    End If
End Function

Function myLenB(s As String) As Long
    myLenB = LenB(s)
End Function

Function myLeftB(s As String, n As Long) As String
    myLeftB = Left(s, n)
End Function