[Tasos]

Καλησπέρα Θανάση!

Για αντιγραφή μόνο φιλτραρισμένων εγγραφών δοκίμασε τον παρακάτω κώδικα στο παράδειγμα του προηγούμενου μηνύματος μου (αντικαθιστά τον παλιό "CopyToTable"):

Sub CopyToTable(ByVal SourceList As ListObject, _
                ByVal TargetList As ListObject, _
                ByVal rng As Range, _
                ByVal rng1 As Range)
    Dim i As Long, t As Long, s As Long, x As Long, c As Long, lstRow As ListRow

    If IsEmpty(rng.Cells(1)) Then Exit Sub

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    c = SourceList.ListColumns.Count
    s = WorksheetFunction.Subtotal(3, rng)
    With TargetList
        t = .ListRows.Count + 1
        .Resize .Range.Resize(t + s, .ListColumns.Count)
        i = t
        For Each lstRow In SourceList.ListRows
            If Not lstRow.Range.EntireRow.Hidden Then
                TargetList.ListRows(i).Range(1, 1).Value = Application.Max(rng1) + 1
                TargetList.ListRows(i).Range(1, 2).Value = Now
                TargetList.ListRows(i).Range.Offset(, 2).Resize(1, c).Value = lstRow.Range.Value
                i = i + 1
            End If

        Next
    End With
    Application.Calculation = xlCalculationAutomatic
    If t + s - 1 > 0 Then MsgBox "Εγινε!", vbInformation, "ms-office.gr"
End Sub

Αν θέλεις να τρέχεις όλες τις μακροεντολές τη μια μετά την άλλη για να αντιγράψεις εγγραφές και έπειτα να τις διαγράψεις από την πηγή μπορείς να χρησιμοποιήσεις:

Sub CopyAllAndClear()
    CopyGreenTable
    copyYellowTable
    ClearGreenTable
    ClearYellowTable
End Sub

Διόρθωσα τον κώδικα και στο συνημμένο του προηγούμενου μηνύματος μου.

Φιλικά

Τάσος