Copy and Pasting without select vba

Copy Visible Cells in a Column

• The feedback to my post Function vs Sub(ByRef) was kind of groundbreaking to my understanding of the difference between ByVal and ByRef (and accidentally error handling, too). Basically, to your surprise, you will rarely need ByRef.

Option Explicit Sub YourPBFCode() Dim wb As Workbook: Set wb = ThisWorkbook Dim sws As Worksheet: Set sws = wb.Worksheets("source") Dim dws As Worksheet: Set dws = wb.Worksheets("target") CopyVisibleCellsInColumn sws.Range("G2"), dws.Range("C2") End Sub ' Just a test (example). Sub CopyVisibleCellsInColumnTEST() Const sName As String = "Sheet1" Const sAddr As String = "A2" Const dName As String = "Sheet2" Const dAddr As String = "A2" Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code ' Source Dim sws As Worksheet: Set sws = wb.Worksheets(sName) Dim sfCell As Range: Set sfCell = sws.Range(sAddr) ' Destination Dim dws As Worksheet: Set dws = wb.Worksheets(dName) Dim difCell As Range: Set difCell = dws.Range(dAddr) CopyVisibleCellsInColumn sfCell, difCell End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Purpose: Copies the visible cells of a one-column range to another ' one-column range. The source range is defined by its first cell ' and the last cell in its column of its worksheet's used range. ' The column of the destination range is defined by its first ' initial cell. The first row of the destination range ' will be the row of the last non-empty cell in the column ' increased by one aka the first available row. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub CopyVisibleCellsInColumn( _ ByVal SourceFirstCell As Range, _ ByVal DestinationInitialFirstCell As Range) If SourceFirstCell Is Nothing Then Exit Sub If DestinationInitialFirstCell Is Nothing Then Exit Sub ' Create a reference to the Source Range ('srg'). Dim sfCell As Range: Set sfCell = SourceFirstCell.Cells(1) Dim srg As Range: Set srg = RefVisibleCellsinColumn(sfCell) If srg Is Nothing Then Exit Sub ' no data ' Create a reference to the Destination Range ('drg'). Dim difCell As Range: Set difCell = DestinationInitialFirstCell.Cells(1) Dim dfCell As Range: Set dfCell = RefFirstAvailableCellInColumn(difCell) If dfCell Is Nothing Then Exit Sub ' no available cells Dim srCount As Long: srCount = srg.Cells.Count If srCount > dfCell.Worksheet.Rows.Count - dfCell.Row + 1 Then Exit Sub ' does not fit End If Dim drg As Range: Set drg = dfCell.Resize(srCount) ' Write values from the Source Range to the Destination Array ('dData'). Dim dData As Variant: dData = GetColumnMultiRange(srg) ' Write values from the Destination Array to the Destination Range. drg.Value = dData End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Purpose: Creates a reference to the visible cells of the range ' at the intersection of the one-column range from the first cell ' of a range ('FirstCellRange') to the bottom-most worksheet cell, ' and the used range of the worksheet. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Function RefVisibleCellsinColumn( _ ByVal FirstCellRange As Range) _ As Range If FirstCellRange Is Nothing Then Exit Function Dim fCell As Range: Set fCell = FirstCellRange.Cells(1) Dim wsrCount As Long: wsrCount = fCell.Worksheet.Rows.Count Dim crg As Range: Set crg = fCell.Resize(wsrCount - fCell.Row + 1) On Error Resume Next Set RefVisibleCellsinColumn = _ Intersect(crg.Worksheet.UsedRange, crg).SpecialCells(xlCellTypeVisible) On Error GoTo 0 End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Purpose: In the one-column range ('crg') from the first cell ('fCell') ' of a range ('FirstCellRange') to the bottom-most worksheet cell, ' creates a reference to the first available cell ' i.e. the cell below the last non-empty cell ('lCell.Offset(1)'). ' If the one-column range ('crg') is empty, ' the first cell ('fCell') is also the first available cell. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Function RefFirstAvailableCellInColumn( _ ByVal FirstCellRange As Range) _ As Range If FirstCellRange Is Nothing Then Exit Function Dim fCell As Range: Set fCell = FirstCellRange.Cells(1) Dim wsrCount As Long: wsrCount = fCell.Worksheet.Rows.Count Dim crg As Range: Set crg = fCell.Resize(wsrCount - fCell.Row + 1) Dim lCell As Range: Set lCell = crg.Find("*", , xlFormulas, , , xlPrevious) If lCell Is Nothing Then Set RefFirstAvailableCellInColumn = fCell Else If lCell.Row < wsrCount Then Set RefFirstAvailableCellInColumn = lCell.Offset(1) End If End If End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Purpose: Returns the values of the first columns of each single range ' of a multi-range in a 2D one-based one-column array. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Function GetColumnMultiRange( _ ByVal ColumnMultiRange As Range) _ As Variant On Error GoTo ClearError ' too many areas, "RTE '7': Out of memory" If ColumnMultiRange Is Nothing Then Exit Function Dim aCount As Long: aCount = ColumnMultiRange.Areas.Count Dim aData As Variant: ReDim aData(1 To aCount, 1 To 2) Dim ocData As Variant: ReDim ocData(1 To 1, 1 To 1) Dim arg As Range Dim a As Long Dim arCount As Long Dim drCount As Long For Each arg In ColumnMultiRange.Areas a = a + 1 With arg.Columns(1) arCount = .Rows.Count If arCount = 1 Then ' one cell ocData(1, 1) = .Value aData(a, 1) = ocData Else ' multiple cells aData(a, 1) = .Value End If End With aData(a, 2) = arCount drCount = drCount + arCount Next arg 'Debug.Print aCount, arCount, drCount Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1) Dim ar As Long Dim dr As Long For a = 1 To aCount For ar = 1 To aData(a, 2) dr = dr + 1 dData(dr, 1) = aData(a, 1)(ar, 1) Next ar Next a GetColumnMultiRange = dData ProcExit: Exit Function ClearError: Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description Resume ProcExit End Function