Copy abbrechen wenn in Range keine Zellen

Bild

Betrifft: Copy abbrechen wenn in Range keine Zellen
von: P-Quest:-)
Geschrieben am: 23.08.2015 14:44:46

Hallo,
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:="<" & Format(dtGJA, "MM-DD-YYYY")
    End With
    
    wsQuelle.Select
    wsQuelle.Range(Cells(6, 1), Cells(lngLastRow, 13)).SpecialCells(xlCellTypeVisible).Copy
    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
Der Fehler wird durch die Zeile
wsQuelle.Range(Cells(6, 1), Cells(lngLastRow, 13)).SpecialCells(xlCellTypeVisible).Copy
ausgelöst.
Danke im Voraus,
Peter

Bild

Betrifft: AW: Copy abbrechen wenn in Range keine Zellen
von: Sepp
Geschrieben am: 23.08.2015 15:58:14
Hallo Peter,

Public Sub BuchNachStichtagSik(vjahr)
Dim ws As Worksheet, wsQuelle As Worksheet, wsZiel As Worksheet
Dim lngLastRow As Long
Dim strSich As String
Dim a As Boolean
Dim dtGJA As Date, dtGJE As Date
Dim rngCopy As Range

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:="<" & Format(dtGJA, "MM-DD-YYYY")
End With

wsQuelle.Select
On Error Resume Next
Set rngCopy = wsQuelle.Range(Cells(6, 1), Cells(lngLastRow, 13)).SpecialCells(xlCellTypeVisible)
Err.Clear
On Error GoTo 0
If Not rngCopy Is Nothing Then
  rngCopy.Copy
  wsZiel.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
  rngCopy.Delete
End If

wsQuelle.ListObjects("Bewegungen").AutoFilter.ShowAllData
Application.CutCopyMode = False

Set rngCopy = Nothing
End Sub


Gruß Sepp


Bild

Betrifft: AW: Copy abbrechen wenn in Range keine Zellen
von: P-Quest:-)
Geschrieben am: 23.08.2015 17:15:05
Besten Dank...mal wieder :-)

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Copy abbrechen wenn in Range keine Zellen"