指定した原紙シートをコピーして新たなシートを作成し、シート名を指定した名前に変更し、その中の指定アドレスに指定配列を丸ごと貼り付けてついでに列幅まで調整したうえでテーブル化し、最後にそのテーブルを戻り値とする関数

過去に作成して提供した、Excelツールの改修を依頼された。作ったのは、２年ほど前か。中身を見て、愕然とする。その作りの、何と酷いことよ。
f:id:Infoment:20190927204342p:plain

その中で、結構な行数を費やしている箇所があった。

ある範囲のデータを、配列に格納する。
「原紙」シートをコピーする。
コピーしたシートの名前を、そのデータに合わせて変更。
指定したセルを起点として、その配列を貼り付ける。
貼り付けたデータをテーブル書式に変更する。
そのテーブルを変数にセットする。
テーブルに対し、色々と操作する（以降省略）

再現すると、こんな感じか。

Sub Abe_shi()
    Dim arr() As Variant
        arr = Sheets("生データ").Range("A1:C3").Value
        
        Sheets("原紙").Copy After:=Sheets(Sheets.Count)
    Dim Sh As Worksheet
    Set Sh = ActiveSheet
        Sh.Name = "入荷レポート"
        
        Sh.Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Sh.ListObjects.Add(xlSrcRange, Sh.UsedRange, , xlYes).Name = "テーブル1"

        Sh.Cells.EntireColumn.AutoFit

    Dim Tb As ListObject
    Set Tb = Sh.ListObjects(1)
        Tb.ListColumns("入荷日").DataBodyRange.NumberFormatLocal = "m/d"
End Sub

f:id:Infoment:20190927210111p:plain
f:id:Infoment:20190927210129p:plain
f:id:Infoment:20190927210152p:plain

何だかいつも、似たようなことを繰り返している。
そう思った瞬間、強烈に嫌になった。そこで、先日の配列貼り付けマクロをさらに拡張してみた。

' destination As String 貼り付け先アドレス　例．A1
' sheet_name As String　貼り付け先シート名
'   無指定の場合・・・ActiveSheet
'   既存名を指定・・・指定名のシート
'   指定名が無い・・・指定名で新規シートを作成
' copy_sheet As Boolean 指定シートをコピーしたうえで貼り付けるか
' new _name As String コピーしたシートの名前
'   無指定の場合・・・Excelがコピーした際につけた名前のままとなる
' paste_type as PasteType テータまたはテーブルを選択
' column_autofit As Boolean 貼り付け後の列幅自動調整
' 配列をシートへ貼り付け。
Public Function PasteArray(destination As String, _
                  Optional sheet_name As String = vbNullString, _
                  Optional copy_sheet As Boolean = False, _
                  Optional new_name As String = vbNullString, _
                  Optional paste_type As PasteType = ptRange, _
                  Optional column_autofit As Boolean = False) As Variant

    Dim Ws As Worksheet
    Dim Sh As Worksheet
        ' シート名の指定がない場合、
        If sheet_name = vbNullString Then

        ' ActiveSheetにそのまま貼り付ける場合と、原紙シートのようなものを
        ' コピーして使用する場合で分岐。
            Select Case copy_sheet
                Case False
                    Set Sh = ActiveSheet
                Case True
                    ActiveSheet.Copy After:=Sheets(Sheets.Count)
                    Set Sh = ActiveSheet
                    If new_name <> vbNullString Then
                        Sh.Name = new_name
                    End If
            End Select

        ' シート名の指定があって、かつシートが存在する場合、そのシートに貼り付ける｡
        ' ただし、copy_sheetフラグがTrueの場合は、そのシートをコピーしたうえで貼り付ける｡
        ' シート名の指定があって、かつシートが存在しない場合、シートを新規作成する｡
        Else
            For Each Ws In Worksheets
                If Ws.Name = sheet_name Then
                    Select Case copy_sheet
                        Case False
                            Set Sh = Ws
                        Case True
                            Ws.Copy After:=Sheets(Sheets.Count)
                            Set Sh = ActiveSheet
                            If new_name <> vbNullString Then
                                Sh.Name = new_name
                            End If
                    End Select
                    Exit For
                End If
            Next
            If Sh Is Nothing Then
                Sheets.Add After:=Sheets(Sheets.Count)
                Set Sh = ActiveSheet
                    Sh.Name = sheet_name
            End If
        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")

            Sh.ListObjects.Add(xlSrcRange, _
                                        TargetRange.CurrentRegion, _
                                        , _
                                        xlYes).Name = TableName
            Set PasteArray = Sh.ListObjects(TableName)
    Else
    ' 貼り付けタイプが範囲の場合、戻り値を貼り付け先シートとする。
        Set PasteArray = Sh
    End If

    If column_autofit Then
        TargetRange.EntireColumn.AutoFit
    End If

End Function

すると、先程のマクロは、ここまで短くなった。

Sub Abe_shi()
    Dim arr() As Variant
        arr = Sheets("生データ").Range("A1:C3").Value
    
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    Dim Tb As ListObject
    Set Tb = SQC.TargetArray(arr).PasteArray("A2", "原紙", True, "入荷レポート", ptTable, True)
        Tb.ListColumns("入荷日").DataBodyRange.NumberFormatLocal = "m/d"
End Sub