Select 选择的标题要与选择本身结合？

Question

通过使用手册 selection(s) ，我将范围从工作簿复制到另一个工作簿。
但是，如何select这个selection(s)的标题与selection本身结合，实现一次复制粘贴。
标题位于第一行。
例如，连续select离子如果我selected范围“B3:D5” ，随后我需要 select ”B1:D1” 和 union 范围 “B3:D5”。
例如，non-contiguous selection 如果我 selected Range “B3:D5,F3:F5” ，随后我需要 select ”B1:D1,F1” 和 union 范围 “B3:D5,F3:F5”
连续 selection 和非连续 selection（在同一行）的复制没有问题。
提前感谢有用的回答和评论。

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

选择复制Header

新解决方案

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

Select 选择的标题要与选择本身结合？

Select Headings of selection(s) to be union with the selection(s) itself?

excel

vba

copy

range

选择复制Header