新規シートを追加してから貼り付け　の続き - Infomentのブログ～Excel VBA奮闘記～

先日、配列をシートに貼り付ける際、新規シートを追加してから貼り付けられるようにしてみた。
infoment.hatenablog.com

このマクロには問題があった。例えば配列を「新規シートのA1」に貼り付ける際、引数を渡した時点で「新規シートのA1」は存在しないため、新規シートを追加したのちにセットし直す必要があったのだ。この点について二人の方から、ご指摘・ご助言も頂いた。

そこで、次のとおり作り直すことにした。

貼り付け先の指定（引数）は、Rangeではなく、Addressとする。
貼り付け先のシートを指定しない場合、ActiveSheetを貼り付け先とする。
貼り付け先のシートをシート名で指定した際、当該シートが存在しない場合、同名のシートを新規に作成して貼り付ける。
ついでに、貼り付け後の列幅調整を引数に追加。

以上を踏まえると、↓ こんな感じだ。

' destination As String 貼り付け先アドレス　例．A1
' sheet_name As String　貼り付け先シート名
'   無指定の場合・・・ActiveSheet
'   既存名を指定・・・指定名のシート
'   指定名が無い・・・指定名で新規シートを作成
' paste_type as PasteType テータまたはテーブルを選択
' column_autofit As Boolean 貼り付け後の列幅自動調整
' 配列をシートへ貼り付け。
Public Function PasteArray(destination As String, _
                  Optional sheet_name As String = vbNullString, _
                  Optional paste_type As PasteType = ptRange, _
                  Optional column_autofit As Boolean = False) As ListObject

    Dim Ws As Worksheet
    Dim Sh As Worksheet
        ' シート名の指定がない場合、アクティブシートに貼り付け。
        If sheet_name = vbNullString Then
            Set Sh = ActiveSheet
        ' シート名の指定があって、かつシートが存在する場合、そのシートに貼り付ける。
        ' シート名の指定があって、かつシートが存在しない場合、シートを新規作成する。
        Else
            For Each Ws In Worksheets
                If Ws.Name = sheet_name Then
                    Set Sh = Ws
                    Exit For
                End If
                If Sh Is Nothing Then
                    Sheets.Add After:=Sheets(Sheets.Count)
                    Set Sh = ActiveSheet
                        Sh.Name = sheet_name
                End If
            Next
        End If

    Dim DestinationRange As Range
    On Error Resume Next
    Set DestinationRange = Sh.Range(destination)
    On Error GoTo 0

    If Err.Number <> 0 Then
        MsgBox "貼り付け先のアドレス指定に誤りがあるため、処理を中断します。"
        Exit Function
    End If


    Dim TargetRange As Range
    Set TargetRange = DestinationRange.Resize(rMax - rMin + 1, cMax - cMin+ 1)
        TargetRange = source_array

    If paste_type = ptTable Then
        Dim TableName As String
            TableName = "Table_" & Format(Now, "yyyymmdd_hhmmss")

            ActiveSheet.ListObjects.Add(xlSrcRange, _
                                        TargetRange, _
                                        , _
                                        xlYes).Name = TableName
            Set PasteArray = ActiveSheet.ListObjects(TableName)
    End If

    If column_autofit Then
        TargetRange.EntireColumn.AutoFit
    End If

End Function