Copy abbrechen wenn in Range keine Zellen
23.08.2015 14:44:46
P-Quest:-)
ich wende auf eine Tabelle einen Filter an und kopiere diese Werte in eine andere Tabelle.
Das Programm bricht mit der Meldung "Keine Zellen gefunden" ab, wenn...keine Zellen gefunden wurden.
Wie kann ich diesen Abbruch sauber umgehen, wenn die Range leer ist?
Public Sub BuchNachStichtagSik(vjahr)
Dim ws As Worksheet
Dim wsQuelle As Worksheet
Dim wsZiel As Worksheet
Dim lngLastRow As Long
Dim strSich As String
Dim a As Boolean
Dim dtGJA As Date
Dim dtGJE As Date
dtGJA = "01.07." & vjahr
dtGJE = "30.06." & vjahr + 1
a = False
strSich = "SikBuch"
For Each ws In Worksheets
If ws.Name = strSich Then a = True
Next
If a Then Worksheets(strSich).Delete
Set wsZiel = Worksheets.Add
With wsZiel
.Name = strSich
.Move after:=Sheets(Sheets.Count)
End With
Set wsQuelle = Worksheets("EinAus")
Set wsZiel = Worksheets(strSich)
lngLastRow = wsQuelle.Cells(Rows.Count, 1).End(xlUp).Row
'Filter setzen - nur Daten aus GJ
With wsQuelle.ListObjects("Bewegungen")
If Not .AutoFilter Is Nothing Then
.AutoFilter.ShowAllData
Else
.Range.AutoFilter
End If
.Range.AutoFilter Field:=6, Criteria1:=">" & Format(dtGJE, "MM-DD-YYYY"), _
Operator:=xlOr, Criteria2:="wsQuelle.Select
wsQuelle.Range(Cells(6, 1), Cells(lngLastRow, 13)).SpecialCells(xlCellTypeVisible).Copy _
i>
wsZiel.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
wsQuelle.Range(Cells(6, 1), Cells(lngLastRow, 13)).SpecialCells(xlCellTypeVisible).Delete
wsQuelle.ListObjects("Bewegungen").AutoFilter.ShowAllData
Application.CutCopyMode = False
End Sub
wsQuelle.Range(Cells(6, 1), Cells(lngLastRow, 13)).SpecialCells(xlCellTypeVisible).Copy
ausgelöst.
Danke im Voraus,
Peter