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

CodePudding user response：

Copy Filtered Rows From Excel Table

Sub CopyFilteredRows()
    
    Const WorksheetName As String = "CC2"
    Const TableName As String = "Tabela452"
    Const CriteriaColumnName As String = "CC"
    Const Criteria As String = "<>"
    
    ' 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
            Set rrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' Clear the filter.
        .AutoFilter.ShowAllData
    End With
    
    If rrg Is Nothing Then
        MsgBox "No filtered rows.", vbExclamation
        Exit Sub
    End If
    
    ' Copy.
    
    rrg.Copy
    
End Sub

CodePudding user response：

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

CodePudding user response：

Use Union to select a non-contiguous range.

Option Explicit

Sub CopyValues()

    Const startingRow As Long = 3
    
    Dim rng As Range, rngB As Range
    Dim lastRow As Long
    
    With Sheets("CC2")
        lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
        For Each rngB In .Range("B" & startingRow & ":B" & lastRow)
            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
    
    rng.Select
    rng.Copy
    MsgBox "range copied " & rng.Address, vbInformation
        
End Sub