Excelの表をTextile形式のテーブルにしてみる

選択した領域をTextile形式のテーブルとしてクリップボードにコピーします。
セルが結合されていてもある程度までは破綻しないはず。
セルの背景色は無視してます。

コード

Option Explicit

'Textileをクリップボードに書き出す
Sub Copy_Textile()
    Dim cl As Range
    Set cl = Selection
    If cl.Count = 1 Then
        MsgBox "出力領域が選択されていません。"
        Exit Sub
    End If

    Dim textile As String
    textile = ConvTextile(cl)
    
    Call SetCB(textile)

    MsgBox "クリップボードにコピーしました。" & vbCrLf & vbCrLf & textile
End Sub

Sub SetCB(ByVal str As String)
    'クリップボードに文字列を格納
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = str
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
End Sub

'指定されたセル範囲をTextileに変換
Function ConvTextile(rng As Range) As String

    Dim i As Long

    Dim rtmp As Range
    Dim mTop As Range

    Dim rSpan, cSpan As Long
    Dim aStr As String
    Dim sStr As String
    Dim strREC As String
    Dim dStr As String  ' to cleanup text
    Dim hl As String    ' for Hyperlink

    Dim stmp As String
    stmp = ""

    ' 左端列を記憶
    Dim rLast As Long
    rLast = 0

    Dim pc As Long
    Dim pr As Long
    Dim cl As Range
    For Each cl In rng

        ' 表示されているセルのみ対象とする
        ' SelectionにSpecialCells(xlCellTypeVisible)を付けると
        ' 取得されるセルの順番が縦優先になってしまうので使えない
        If cl.Rows.Hidden = False And cl.Columns.Hidden = False Then

            ' 上端の列を取得
            If rLast = 0 Then rLast = cl.Row
            If cl.Row <> rLast Then
                'If strREC <> "" Then
                    'テーブルを閉じる
                    strREC = strREC & "|"
                    stmp = stmp & strREC & vbCrLf
                    
                    strREC = ""
                'End If
                rLast = cl.Row
            End If

            ' セルが結合されている場合
            If cl.MergeCells Then
                ' 基点が非表示の場合の考慮が必要なので
                ' 結合セルの表示されている一番左上のセルとの一致を判定
                ' 表示されている一番左上のセルを取得
                For i = 1 To cl.MergeArea.Count
                    Set mTop = cl.MergeArea.Item(i)
                    If mTop.Rows.Hidden = False And mTop.Columns.Hidden = False Then
                        Exit For
                    End If
                Next i

                ' 処理対象のセルと一致していなければループに戻る
                If cl.Address <> mTop.Address Then
                    GoTo Continue
                End If

            End If

            aStr = ""
            sStr = ""

            With cl.MergeArea

                ' 結合範囲の取得
                rSpan = .Rows.Count
                cSpan = .Columns.Count

                ' セルが結合されている場合
                If cl.MergeCells Then
                
                    pc = .Item(1).Column
                    pr = .Item(1).Row
                    
                    ' 結合範囲内の非表示分を減算
                    For i = 1 To .Rows.Count - 1
                        If Cells(pr + i, pc).Rows.Hidden = True Then
                            rSpan = rSpan - 1
                        End If
                    Next i
                    For i = 1 To .Columns.Count - 1
                        If Cells(pr, pc + i).Columns.Hidden = True Then
                            cSpan = cSpan - 1
                        End If
                    Next i

                    ' 結合セル数をTextile形式に
                    If rSpan > 1 Then sStr = "/" & rSpan
                    If cSpan > 1 Then sStr = sStr & "\" & cSpan

                End If

                ' 配置情報を取得
                If .HorizontalAlignment = xlLeft Then aStr = "<"
                If .HorizontalAlignment = xlRight Then aStr = ">"
                If .HorizontalAlignment = xlCenter Then aStr = "="

                If .VerticalAlignment = xlVAlignTop Then aStr = aStr & "^"
                If .VerticalAlignment = xlVAlignBottom And rSpan > 1 Then aStr = aStr & "~"

                ' ハイパーリンクの取得
                hl = linkAddress(.Item(1))

                If .Item(1).Text = "" Then aStr = ""

                strREC = strREC & "|" & sStr & aStr
                If sStr <> "" Or aStr <> "" Then strREC = strREC & ". "

                ' 前後の改行を削除
                ' 空行も削除
                ' 前後の空白も削除
                dStr = Trim(TrimLF(Replace(.Item(1).Text, vbLf & vbLf, vbLf)))

                ' ハイパーリンクがある場合
                If hl <> "" Then
                    strREC = strREC & """" & Replace(dStr, vbLf, vbCrLf) & """:" & hl
                Else
                    ' セル修飾対応
                    If dStr <> "" Then
                        ' 斜体
                        If .Item(1).Font.Italic Then
                            dStr = "_" & dStr & "_"
                        End If
                        ' 下線
                        If .Item(1).Font.Underline <> xlUnderlineStyleNone Then
                            dStr = "+" & dStr & "+"
                        End If
                        ' 打ち消し線
                        If .Item(1).Font.Strikethrough Then
                            dStr = "-" & dStr & "-"
                        End If
                        ' 太字
                        If .Item(1).Font.Bold Then
                            dStr = "*" & dStr & "*"
                        End If
                    End If

                    strREC = strREC & Replace(dStr, vbLf, vbCrLf)
                End If

            End With

        End If ' Not Hidden

Continue:
    Next ' Selection

    ' 残処理
    If strREC <> "" Then
        strREC = strREC & "|"
        stmp = stmp & strREC & vbCrLf
    End If

    ConvTextile = stmp
End Function

'ハイパーリンクを取得
Public Function linkAddress(r As Range) As String
    If r.Hyperlinks.Count > 0 Then '指定したセルにハイパーリンクオブジェクトがある
        linkAddress = r.Hyperlinks(r.Hyperlinks.Count).Address
        If r.Hyperlinks(r.Hyperlinks.Count).SubAddress <> "" Then
            linkAddress = linkAddress & "#" & r.Hyperlinks(r.Hyperlinks.Count).SubAddress
        End If
    Else
        If InStr(r.Formula, "=HYPERLINK") Then 'HYPERLINK関数を使っている
            linkAddress = Mid(r.Formula, 13, InStr(13, r.Formula, """") - 13)
        Else
            linkAddress = ""
        End If
    End If
End Function

' 文字列前後の改行を削除
Function TrimLF(str As String) As String
    Dim strTmp As String
    strTmp = str
    Do Until Left(strTmp, 1) <> vbLf
        strTmp = Mid(strTmp, 2)
    Loop
    Do Until Right(strTmp, 1) <> vbLf
        strTmp = Left(strTmp, Len(strTmp) - 1)
    Loop
    TrimLF = strTmp
End Function

アドインにして右クリックメニューから動くようExcelに組み込んでおくと便利でした（過去形）。

追記

すみません、セルが結合されていて且つその一部分が非表示になっている場合の処理をミスってました。
Excel 2016への対応含めて、今はこう書き直してます。