Einsatz von EntireRow (Prozedurfehler)
01.02.2005 18:00:22
EntireRow
bräuchte ganz dringend eure Hilfe bei einer von mir erstellten Prozedur.
Ich habe eine Excel-Tabelle vorliegen, in welcher in der Spalte AG Datumswerte eingetragen sind. Immer wenn im Datum 04 für 2004 vorkommt, soll die komplette Zeile in eine neue Tabelle übergeben werden.
Komm da nicht mehr weiter! Hat von euch jemand eine Idee?
Hier mein Code:
________________________________________________________________________________
Option Explicit
Dim WSNeu As Worksheet 'Daten Filtern (Modulweite Variable)
Dim lngZeile As Long 'Daten Filtern (Modulweite Variable)
Sub DatenFiltern()
Dim WS As Worksheet
Dim strBlatt As String
Dim Zeile As Variant
Dim rngBegin As Range
' alte Blätter löschen
On Error Resume Next
Application.DisplayAlerts = False
For Each WS In ActiveWorkbook.Worksheets
If Left(WS.Name, 8) = "Tabelle1" Then WS.Delete
Next WS
Application.DisplayAlerts = True
On Error GoTo 0
' neues Blatt Anlegen
strBlatt = "2004"
On Error Resume Next
Set WSNeu = ActiveWorkbook.Worksheets(strBlatt)
If Err.Number <> 0 Then
Set WSNeu = ActiveWorkbook.Worksheets.Add
WSNeu.Name = strBlatt
End If
On Error GoTo 0
Set WS = Application.ActiveWorkbook.Worksheets("ABR550_MONA0501_MAN55000_AK00_R")
' Bildschrimaktualisierung aufheben
'With Application
' .ScreenUpdating = False
' .Calculation = xlCalculationManual
' .EnableEvents = False
'End With
' Wertzuweisung der Zeileninhalte
lngZeile = 1
Set rngBegin = WS.Range("AG19")
Do Until rngBegin.Value = "Ende"
If Right(rngBegin.Value, 2) = "04" Then
Zeile = ActiveCell.EntireRow.Value
End If
Daten Zeile
Set rngBegin = rngBegin.Offset(1, 0)
Loop
' Bildschrimaktualisierung einschalten
'With Application
' .ScreenUpdating = True
' .Calculation = xlCalculationAutomatic
' .EnableEvents = True
'End With
End Sub
________________________________________________________________________________
Public
Sub Daten(Zeile As Variant)
' Unterprozedeur die den kompletten Zelleninhalt in eine neue Tabelle schreibt
lngZeile = WSNeu.UsedRange.Rows.Count + 1
WSNeu.Cells(lngZeile) = Zeile
End Sub
________________________________________________________________________________
Für eure Hilfe wäre ich sehr Dankbar.
Mfg
Martin