AW: Archivieren
01.12.2008 14:55:24
fcs
Hallo Paul,
das läßt sich nur vernüftigt lösn, wenn du die Formeln im Blatt "Rechnungen" in soweit anpasst, dass in allen Formeln der Zeilen 4 bis 39 der Bezug auf das Blatt selbst entfernt wird.
Also z.B
=WENN(F4="KH";0;G4)
statt
=WENN(Rechnungen!F4="KH";0;Rechnungen!G4)
so werden die Zeilen sortierfähig. Die Anpassung der Formeln kanst du mit "Suchen/Ersetzen" einfach erledigen.
Nach diesen Anpassungen funktioniert das folgende Makro.
Das Makro kopiert die Formate und Inhalte aller Zeilen mit dem Wert 0 in Spalte W und löscht die Inhalte der Eingabe-Zellen.
Im Anschluss werden die Daten nach dem Namen sortiert, wodurch die Leerzeilen nach unten plaziert werden. Für die Sortierung kannst du natürlich auch eine der anderen Eingabespalten wählen.
Die bedingte Formatierung in Spalte W muss auch etwas ergänzt werden, damit leere Zeilen nicht "grün" angezeigt werden.
Hier deine Datei mit entsprechenden Anpassungen
https://www.herber.de/bbs/user/57282.xls
Gruß
Franz
Hier das Makro, das du deinem Button zuordnen muss.
Sub BezahlteRechnungen()
Dim wksRech As Worksheet, lngZeileR As Long
Dim wksBez As Worksheet, lngZeileB As Long
Const LastData = 39 'Letzte Zeile mit Formeln im Blatt Rechnungen
Set wksRech = Worksheets("Rechnungen")
Set wksBez = Worksheets("Bezahlt")
With wksRech
' im Blatt Rechnungen die Spalte W ab Zeile 4 auf Null prüfen, wenn in Spalte A _
eine Kundennummer eingetragen ist.
For lngZeileR = 4 To LastData
If .Cells(lngZeileR, 1) "" _
And Application.WorksheetFunction.Round(.Cells(lngZeileR, 23), 2) = 0 Then
'Spalten A bis AA der Zeile kopieren
.Range(.Cells(lngZeileR, 1), .Cells(lngZeileR, 27)).Copy
With wksBez
'nächste freie Zeile in Spalte A im Blatt Bezahlt
lngZeileB = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Frmate udn Werte kopieren
.Cells(lngZeileB, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(lngZeileB, 1).PasteSpecial Paste:=xlPasteValues
End With
'Inhalte der Eingabezellen in Zeile löschen
.Range(.Cells(lngZeileR, 1), .Cells(lngZeileR, 9)).ClearContents 'Spalte A bis I
.Range(.Cells(lngZeileR, 11), .Cells(lngZeileR, 16)).ClearContents 'Spalte K bis P
.Cells(lngZeileR, 18).ClearContents 'Spalte R
.Cells(lngZeileR, 20).ClearContents 'Spalte T
.Cells(lngZeileR, 22).ClearContents 'Spalte V
.Range(.Cells(lngZeileR, 26), .Cells(lngZeileR, 27)).ClearContents 'Spalte Z bis AA
End If
Next
'Zeilen Sortieren nach Spalte B um Leere Zeilen nach unten zu "schieben"
With .Range(.Cells(3, 1), .Cells(LastData, 27)) 'Datenzeilen
.Sort key1:=.Range("B1"), Order1:=xlAscending, _
header:=xlYes
End With
End With
End Sub