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

user_17797849 0
Viewed 55

By using manual selection(s) , I copy range(s) from workbook to another workbook.
But, how to select the headings of this selection(s) to be union with the selection itself , to fulfill copy and paste in one shot.
Headings are found on first row.
e.g, contiguous selection if I selected Range “B3:D5” , subsequently I need to select ”B1:D1” and union with Range “B3:D5”.
e.g, non-contiguous selection if I selected Range “B3:D5,F3:F5” , subsequently I need to select ”B1:D1,F1” and union with Range “B3:D5,F3:F5”
Copying of contiguous selection and non- contiguous selections (in the same rows) works without problem.
In advance, grateful for useful answer and comments. 

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
range copy vba excel
2 Answers

If you want the Selected range Unioned with row one, try this

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
user_4454250

Copy Header With Selection

New Solution

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

Initial Solution (Covers only ranges in the same columns)

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
user_98140690
Related