Text kopieren und in Leer Zeile einfügen
25.11.2022 15:04:19
Ron
ich habe eine Excel entworfen in dem anhand eines Aufnahmesblattes ein Leistungsverzeichnis geschrieben wird. Da die Excel inzwischen knapp 150 verschiedene Positionen hat und es sehr mühseelig ist die Zeilen zu ändern wenn sich die Positionen verschieben sollten und es auch ewig dauert bis das Leistungverzeichnis generiert wirdist wollte hier fragen ob ihr eine bessere Lösung findet.
Ich habe es schon versucht als Schleife oder Loop umzugestallten aber mir fehlen einfach die Kenntnisse dies sauber zu lösen. Ich hänge schon seit ewigkeiten dran aber komme gar nicht weiter. Deshalb wende ich mich an euch.
Was das Makro macht:
Er überprüft ob zu der angegebene Arbeit aus dem Tabellenblatt(Aufnahmeblatt) der wert größer ist als 1 wenn ja soll er die Summen zusammen nehmen und dies ins Tabellenblatt(LV) übertragen. Aus dem Tabellenblatt(Fließtext) soll er sich die dazugehörige Position kopieren und in Tabellenblatt(LV) an einer bestimmten Zeile einsetzten.
Wenn aber im Tabellenblatt(Aufnahmeblatt) der wert 0 ist soll er gar nichts machen
Im Großen und Ganzen funktioniert das so wie ich das haben will. Problem ist hier nur ich muss so festgelegte Zeilen definieren und die Zeilen in dennen nichts steht löscht er automatisch alle Leere Zeilen. Und das dauert sehr lange bis die Excel damit durch ist.
Meine Idee ist das er immer in die nächste leere Zeile den Text einfügen soll mit einer Schleife oder Loop aber ich habe keine ahnung wie ich das anstellen soll.
Hier ein Ausschnitt
'1.01 Abdecken
If Application.WorksheetFunction.SumIf(Worksheets("Aufnahmeblatt").Columns(2), "Abdeckarbeiten", Worksheets("Aufnahmeblatt").Columns(7)) > 0 Then
Worksheets("Fließtext").Range("A1:H1").Copy
Worksheets("LV").Range("A22:H22").PasteSpecial
Rows("22:22").RowHeight = 13
Worksheets("Fließtext").Range("A2:H2").Copy
Worksheets("LV").Range("A23:H23").PasteSpecial
Rows("23:23").RowHeight = 121
Cells(22, 4) = Application.WorksheetFunction.SumIf(Worksheets("Aufnahmeblatt").Columns(2), "Abdeckarbeiten", Worksheets("Aufnahmeblatt").Columns(7))
Else
Cells(22, 1) = ""
Cells(22, 2) = ""
Cells(22, 4) = ""
Cells(22, 5) = ""
Cells(23, 2) = ""
Cells(23, 4) = ""
End If
'1.02 Tapeten entfernen (Wände)
If Application.WorksheetFunction.SumIf(Worksheets("Aufnahmeblatt").Columns(2), "Tapeten entfernen (Wände)", Worksheets("Aufnahmeblatt").Columns(7)) > 0 Then
Worksheets("Fließtext").Range("A3:H3").Copy
Worksheets("LV").Range("A24:H24").PasteSpecial
Rows("24:24").RowHeight = 13
Worksheets("Fließtext").Range("A4:H4").Copy
Worksheets("LV").Range("A25:H25").PasteSpecial
Rows("25:25").RowHeight = 44
Cells(24, 4) = Application.WorksheetFunction.SumIf(Worksheets("Aufnahmeblatt").Columns(2), "Tapeten entfernen (Wände)", Worksheets("Aufnahmeblatt").Columns(7))
Else
Cells(24, 1) = ""
Cells(24, 2) = ""
Cells(24, 4) = ""
Cells(24, 5) = ""
Cells(25, 2) = ""
Cells(25, 4) = ""
End If