Trying to copy table range with criteria - excel

Question

Im trying to copy a table range with criteria, however I am not able to define the criteria to copy the desired lines, which consists of copying only the lines where the CC column has data skiping the entire row if CC is empty. I'll just copy ( copy to clipboard ), for paste I'll do it manually for other reasons
The lines will always be like this, never with a whole blank line between them like the second image
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For Each rng In .Range("B3:I3" & bottomA)
If WorksheetFunction.Sum(.Range("B" & rng.Row & ":I" & rng.Row)) > 0 Then
Range("B" & rng.Row & ":I" & rng.Row)).Copy
End If
Next rng
End With
Application.ScreenUpdating = True
End Sub

Answer 1

Use Union to select a non-contiguous range.
Option Explicit
Sub CopyValues()
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, rngB As Range
Dim tbl As ListObject
Set wb = ThisWorkbook
Set ws = wb.Sheets("CC2")
With ws.ListObjects("Tabela452")
For Each rngB In .ListColumns("CC").DataBodyRange
If Len(rngB) > 0 Then
If rng Is Nothing Then
Set rng = rngB.Resize(1, 8) ' B to I
Else
Set rng = Union(rng, rngB.Resize(1, 8))
End If
End If
Next
End With
If rng Is Nothing Then
MsgBox "Nothing selected", vbExclamation
Else
rng.Select
rng.Copy
MsgBox "range copied " & rng.Address, vbInformation
End If
End Sub

Answer 2

Please, test the next adapted code. It does not need any iteration:
Sub CopyValues()
Dim rngCopy As Range, tbl As ListObject
Dim srcWS As Worksheet: Set srcWS = Sheets("CC2")
Set tbl = srcWS.ListObjects(1) 'use here the table name, if more than 1
On Error Resume Next 'for the case of no any value in the table first column
Set rngCopy = tbl.DataBodyRange.Columns(1).SpecialCells(xlCellTypeConstants)
'or
'Set rngCopy = tbl.DataBodyRange.Columns(tbl.ListColumns("CC").Index).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngCopy Is Nothing Then 'for the case of no any values in table first column
Intersect(rngCopy.EntireRow, tbl.DataBodyRange).Copy
Else
MsgBox "No any value in column ""CC""..."
End If
End Sub
As I said in my comment, it works if the values in column "CC" are not result of formulas...

Answer 3

Copy Filtered Rows From Excel Table (ListObject)
The screenshot illustrates the benefits of using an Excel table:
The table can be anywhere on the worksheet.
You can easily reference a column by its name (header).
You can move the column anywhere in the table.
Sub CopyFilteredRows()
' Define constants.
Const WorksheetName As String = "CC2"
Const TableName As String = "Tabela452"
Const CriteriaColumnName As String = "CC"
Const Criteria As String = "<>" ' non-blanks ('blank' includes 'empty')
' Reference the objects ('wb', 'ws' , 'tbl', 'lc')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
Dim lc As ListColumn: Set lc = tbl.ListColumns(CriteriaColumnName)
' Reference the filtered rows ('rrg').
Dim rrg As Range
With tbl
If .ShowAutoFilter Then ' autofilter arrows are turned on
' Clear all filters.
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else ' autofilter arrows are turned off
.ShowAutoFilter = True ' turn on the autofilter arrows
End If
.Range.AutoFilter lc.Index, Criteria
' Attempt to reference the filtered rows ('rrg').
On Error Resume Next
' Reference the visible cells.
Set rrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
' When columns are hidden, resize to entire rows of the table.
Set rrg = Intersect(.DataBodyRange, rrg.EntireRow)
On Error GoTo 0
' Clear the filter.
.AutoFilter.ShowAllData
End With
' Invalidate the filtered rows.
If rrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Copy.
rrg.Copy
End Sub

Answer 4

For the criteria when looking for empty values, you can always use LEN to check the number of characters in the cell.
If it is greater than 0 it means that something is in there, you can also set it to an exact amount of digits to be more precise.
Something like this should work:
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Dim currentRow As Long
Const ccColumn As Long = 2
Const startingRow As Long = 3
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For currentRow = startingRow To bottomA
If Len(.Cells(currentRow, ccColumn).Value) > 0 Then
.Range("B" & currentRow & ":I" & currentRow).Copy
End If
Next currentRow
End With
Application.ScreenUpdating = True
End Sub