选择要与选择本身联合的选择标题？

Question

通过使用手动选择，我将范围从工作簿复制到另一个工作簿。
但是，如何选择该选区的标题以与选区本身结合，以实现一次复制和粘贴。
标题位于第一行。
例如，连续选择如果我选择 Range “B3:D5” ，随后我需要选择 ”B1:D1” 和 @987654323 @ 范围为“B3:D5”。
例如，non-contiguous selection 如果我选择 Range “B3:D5,F3:F5” ，随后我需要选择 ”B1:D1,F1” 和 union 和 Range “B3:D5,F3:F5”
复制连续选择和非连续选择（在同一行中）没有问题。
提前感谢有用的答案和cmets。

Dim wb As Workbook: Set wb = ThisWorkbook    'Source Workbook
Dim srg As Range: Set srg = wb.ActiveSheet.Range(Selection.Address)

Dim wb1 As Workbook: Set wb1 = Workbooks.Add  'Destination Workbook
Dim drg As Range: Set drg = wb1.Sheets(1).Range("A1")

srg.Copy
drg.PasteSpecial Paste:=xlPasteColumnWidths
srg.Copy drg      

Dim r As Range
  For Each r In drg.Rows
  r.WrapText = True
    If r.RowHeight < 40 Then r.RowHeight = 40  
       Next r

Answer 1

如果您希望选定范围与第一行联合，请尝试此操作

Dim srg As Range
Dim src As Range
Dim arr As Range
Set src = Selection
For Each arr In src.Areas
    If srg Is Nothing Then
        Set srg = Application.Union(arr, arr.EntireColumn.Rows(1))
    Else
        Set srg = Application.Union(srg, arr, arr.EntireColumn.Rows(1))
    End If
Next

Answer 2

复制标题与选择

新解决方案

Option Explicit

Sub ExportSelection()
    
    Const rRow As Long = 1
    
    If Not TypeOf Selection Is Range Then Exit Sub
    
    Dim rg As Range: Set rg = RefRangeAndRow(Selection, rRow)
    'Debug.Print rg.Address
    
    Dim frrg As Range: Set frrg = Intersect(rg, rg.Worksheet.Rows(rRow))
    
    With Workbooks.Add(xlWBATWorksheet).Worksheets(1).Range("A1")
        frrg.Copy
        .Cells.PasteSpecial xlPasteColumnWidths
        rg.Copy .Cells
    End With

End Sub

Function RefRangeAndRow( _
    ByVal mrg As Range, _
    Optional ByVal RowNumber As Long = 1) _
As Range

    Dim rrg As Range
    Dim arg As Range
    
    For Each arg In mrg.Areas
        If rrg Is Nothing Then
            Set rrg = arg.EntireColumn.Rows(RowNumber)
        Else
            Set rrg = Union(rrg, arg.EntireColumn.Rows(RowNumber))
        End If
    Next arg
    
    If rrg Is Nothing Then
        Set RefRangeAndRow = mrg
    Else
        Set RefRangeAndRow = Union(rrg, mrg)
    End If

End Function

初始解决方案（仅涵盖同一列中的范围）

Sub ExportSelectionInitial()
    
    If Not TypeOf Selection Is Range Then Exit Sub
    
    Dim dfCell As Range
    With Selection
        With Union(.EntireColumn.Rows(1), .Cells)
            .Rows(1).Copy
            Set dfCell = Workbooks.Add(xlWBATWorksheet) _
                .Worksheets(1).Range("A1")
            dfCell.PasteSpecial xlPasteColumnWidths
            .Copy dfCell
        End With
    End With
    
    With dfCell.CurrentRegion ' headers and data
        Dim rrg As Range
        For Each rrg In .Rows
            rrg.WrapText = True
            If rrg.RowHeight < 40 Then rrg.RowHeight = 40
        Next rrg

        With .Rows(1) ' headers
        
        End With
        
        With .Resize(.Rows.Count - 1).Offset(1) ' data
        
        End With
    
        With .Worksheet ' worksheet
            Debug.Print .Name
            With .Parent ' workbook
                Debug.Print .Name
                .Saved = True ' for easy closing when developing
            End With
        End With
    
    End With

End Sub