Neue Zeilen per VBA einfügen?

Hallo Leute,
ich möchte gern per VBA einige neuen Zeilen mit Füllfarben, festen Texten und Formeln einfügen.
I) Ich habe die Tabelle von Zeile 4 bis letzte gefüllte Zeile der Spalte E markiert und wie folgt sortiert:
1. Sortierung nach Spalte H absteigend
2. Sortierung nach Spalte I aufsteigend
II)
Wenn in Spalte H ab Zeile 4 folgender Text vorkommt....
"02" dann soll eine neue Zeile (mit der Füllfarbe grau, von Spalte A bis Spalte P) dadrüber eingefügt werden und in Spalte A dieser neue Zeile der Text "2.Obergeschoss" einmal eingetragen werden.
"01" dann soll eine neue Zeile (mit der Füllfarbe grau, von Spalte A bis Spalte P) dadrüber eingefügt werden und in Spalte A dieser neue Zeile der Text "1.Obergeschoss" einmal eingetragen werden.
"00" dann soll eine neue Zeile (mit der Füllfarbe grau, von Spalte A bis Spalte P) dadrüber eingefügt werden und in Spalte A dieser neue Zeile der Text "Erdgeschoss" einmal eingetragen werden.
III)
Wenn in Spalte H und in Spalte I identisch ist, dann soll folgendes ab Zeile 4 eingetragen werden...
einmal eine neue Zeile (mit der Füllfarbe grün, von Spalte A bis Spalte P) dadrüber eingefügt werden und in Spalte A dieser neue Zeile der Text "Laden:" eingetragen werden. In der Spalte B und Spalte C sollen die Formeln (siehe Arbeitsblatt "Nachher") eingetragen werden.
Wie mache ich das ?
Anbei eine Beispieldatei mit zwei Arbeitsblätter (vorher und nacher) zum besseren Verständnis: https://www.herber.de/bbs/user/54098.xls
Vielen Dank im Voraus !
Viele Grüße,
Selma

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Makro1() Dim zz As Long, strV As String, strW As String, bolE As Boolean, arrT arrT = Split("Erdgeschoss 1.Obergeschoss 2.Obergeschoss") For zz = Cells(Rows.Count, 5).End(xlUp).Row To 4 Step -1 bolE = False If Cells(zz, 8) Cells(zz - 1, 8) Then bolE = True If Cells(zz, 8) & Cells(zz, 9) Cells(zz - 1, 8) & Cells(zz - 1, 9) Then Rows(zz).Insert With Cells(zz, 1).Resize(, 16) .EntireRow.AutoFit .Orientation = 0 .HorizontalAlignment = xlGeneral .Interior.ColorIndex = 35 With .Font .Size = 15 .ColorIndex = xlAutomatic .Bold = True End With .Cells(1) = "Laden:" With .Cells(2) .Resize(, 2).NumberFormat = "General" .FormulaR1C1 = "="" ""&R[1]C[6]&R[1]C[7]" .Font.ColorIndex = 13 End With .Cells(3).FormulaR1C1 = "=R[1]C5" End With End If If bolE Then Rows(zz).Insert With Cells(zz, 1).Resize(, 16) .EntireRow.AutoFit .Orientation = 0 .HorizontalAlignment = xlGeneral .Interior.ColorIndex = 15 With .Font .Size = 24 .ColorIndex = xlAutomatic .Bold = True End With .Cells(1) = arrT(Cells(zz + 2, 8)) End With End If Next zz End Sub

Hi Selma,
nun erweitert:


Option Explicit
Sub Makro1()
Dim zz As Long, strV As String, strW As String, bolE As Boolean, arrT
arrT = Split("Erdgeschoss 1.Obergeschoss 2.Obergeschoss")
For zz = Cells(Rows.Count, 5).End(xlUp).Row To 4 Step -1
bolE = False
If Cells(zz, 8)  Cells(zz - 1, 8) Then bolE = True
If Cells(zz, 8) & Cells(zz, 9)  Cells(zz - 1, 8) & Cells(zz - 1, 9) Then
Rows(zz).Insert
With Cells(zz, 1).Resize(, 16)
.EntireRow.AutoFit
.Orientation = 0
.HorizontalAlignment = xlGeneral
.Interior.ColorIndex = 35
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Borders(xlInsideVertical).LineStyle = xlNone
With .Font
.Size = 15
.ColorIndex = xlAutomatic
.Bold = True
End With
.Cells(1) = "Laden:"
With .Cells(2)
.Resize(, 2).NumberFormat = "General"
.FormulaR1C1 = "="" ""&R[1]C[6]&R[1]C[7]"
.Font.ColorIndex = 13
End With
.Cells(3).FormulaR1C1 = "=R[1]C5"
End With
End If
If bolE Then
Rows(zz).Insert
With Cells(zz, 1).Resize(, 16)
.EntireRow.AutoFit
.Orientation = 0
.HorizontalAlignment = xlGeneral
.Interior.ColorIndex = 15
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Borders(xlInsideVertical).LineStyle = xlNone
With .Font
.Size = 24
.ColorIndex = xlAutomatic
.Bold = True
End With
.Cells(1) = arrT(Cells(zz + 2, 8))
End With
If zz > 4 Then
'        If Cells(zz, 1)  "2.Obergeschoss" Then  ' vielleicht statt zz > 4
Rows(zz).Insert
With Rows(zz)
.RowHeight = 21
.Borders.LineStyle = xlNone
End With
End If
End If
Next zz
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread