Makro neue Zeilen einfügen in Excel

Anonym

Hallo,

ich hoffe von euch Ihr könnt mir helfen.

Wir haben eine Excel Tabellen mit vielen Datensätzen (Zeilen).

Dort müssen wir ständig neue Zeilen einfügen für neue Datensätze.

In der Zeile sind 2 Formel hinterlegt.

Nun bin auf der suche nach einem Makro das mir die Zeilen neu einfügt, den Inhalt (Schrift Farbe usw.) löscht aber die Formel mit kopiert.

Die Anzahl der neuen Zeile variiert. 1 oder 2 oder 3 oder....

Ich habe da ein Makro gefunden das mir aber immer nur 1 Zeile einfügt und bei Zeilen mit Inhalt diesen Inhalt nicht löscht

1. Makro

Sub Zeilen_einfügen()

Application.ScreenUpdating = False

Selection.EntireRow.Insert

' ACHTUNG: Das With darf nicht 1 drüber, da sich durch das Insert die Selection ändert

With Selection.EntireRow

.FormulaR1C1 = .Offset(-1, 0).Resize(1).FormulaR1C1

End With

Application.ScreenUpdating = True

End Sub

dann habe ich noch ein 2 Makro gefunden,

hier kann ich zwar mehrere Zeile markieren und dann neue Zeilen einfügen aber wieder rum das Problem, wenn ich eine beschriebene Zeile markiere wird der Inhalt nicht gelöscht

2. Makro

Sub zelleneinfügen()

' Zeilen_einfügen Makro

' Makro am 16.09.2010 von Privat aufgezeichnet

If Selection.Areas.Count > 1 Then

MsgBox ("Bitte nicht mehrere Bereiche auswählen!")

Exit Sub

End If

Application.ScreenUpdating = False

Selection.EntireRow.Insert

' ACHTUNG: Das With darf nicht 1 drüber, da sich durch das Insert die Selection ändert

With Selection.EntireRow

.Offset(-1, 0).Resize(1).Copy

.PasteSpecial Paste:=xlPasteFormulas

' Wenn in der Zeile unter den eingefügten Zeilen eine Formel in

' Spalte B steht, dann muss die korrigiert werden

If .Resize(1, 1).Offset(.Rows.Count, 1).HasFormula Then

.Resize(1, 1).Offset(.Rows.Count, 1).FormulaR1C1 = _

.Resize(1, 1).Offset(-1, 1).FormulaR1C1

End If

End With

Application.ScreenUpdating = True

End Sub

und ab hier hätte ich gerne eure Hilfe

Ein Makro das das alles kann

mehrere Zeile einfügt
beschriebene Zeilen löscht
aber alle Formeln kopiert

ist das irgendwie möglich

ich Danke euch

BG und noch schönes WE

Gesperrte Frage. Diese Frage wurde aus der Microsoft-Support-Community migriert. Sie können darüber abstimmen, ob sie hilfreich ist, aber Sie können keine Kommentare oder Antworten hinzufügen oder der Frage folgen.

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

Anonym

Hallo Steffi,

probiers mal mit Schraffur:

Sub FindenFaerben()

Dim Such As Variant

Dim arrSuch As Variant

Dim c As Range, rngC As Range

Dim FirstAddress As String

Such = Application.InputBox("Gib hier deinen Suchbegriff ein" _

& Chr(10) & " und semikolongetrennt" & Chr(10) & _

"eine 0 für Suche in ganzer Zelle" _

& Chr(10) & "eine 1 für Suche in Teil der Zelle", _

"Suchbegriff", Type:=3)

arrSuch = Split(Such, ";")

Application.ScreenUpdating = False

With ActiveSheet

With .UsedRange.Interior

.Pattern = xlNone

.TintAndShade = 0

.PatternTintAndShade = 0

End With

Set c = .UsedRange.Find(arrSuch(0), LookIn:=xlValues, _

lookat:=IIf(arrSuch(1) = 0, xlWhole, xlPart))

If Not c Is Nothing Then

FirstAddress = c.Address

With c.Interior

.Pattern = xlLightUp

.PatternColorIndex = xlAutomatic

.ColorIndex = xlAutomatic

End With

Set c = .UsedRange.FindNext(c)

Loop While Not c Is Nothing And c.Address <> FirstAddress

End If

End With

Application.ScreenUpdating = True

End Sub

Mit freundlichen Grüßen

Claus

0 Kommentare

52 zusätzliche Antworten

Anonym

2014-08-23T09:15:12+00:00

Hallo Claus,

mit der Schraffierung sieht es schon besser aus;

jetzt aber das Problem das die Zellen wo keine Bedingte Formatierung besteht (bei mir die Kopfzeile) alle Farben verschwinden und alles Weiß ist,

Danke

BG
War diese Antwort hilfreich?

0 Kommentare Keine Kommentare
Anonym

2014-08-23T10:32:58+00:00

Hallo Claus,

nochmal zum Suchen und Finden,

ich habe mich auch mal in anderen Foren umgehört und es ist wohl ein sehr komplexes Thema,

zu dem vorigen Beitrag,

die Zellen die von mir mit der Hand farblich markiert sind werde ich mit einer bedingten Formatieren festlegen so das diese Zellen ihre Farben beibehalten,

wäre es aber möglich in der Schraffierung mit "Strichen" dieses farblich "Lila" zu gestalten ?

Farbcode:

RGB

Rot: 204

Grün: 0

Blau: 204

Danke

BG
War diese Antwort hilfreich?

0 Kommentare Keine Kommentare
Anonym

2014-08-23T10:35:16+00:00

Hallo Steffi,

ich wusste ja nicht, dass du eine Menge Formate in deiner Tabelle hast. Es ist aber zu viel Aufwand für eine einfache Suche durch alle Zellen der Tabelle zu gehen und die zugehörige Adresse und Formate in ein Array zu schreiben und nachher alles wieder zurück zu formatieren.

Angenommen deine Tabelle heißt Tabelle1. Dann lege noch eine Tabelle2 an oder ändere den Blattnamen im Code. Dann kannst du deine Tabelle auf nach Blatt2 kopieren und anschließend die Formate wieder herstellen.

Dazu habe ich jetzt 2 Makros. Das Makro "Format" kannst du auch verwenden, um die Schraffur zu entfernen, wenn du fertig bist mit der Suche. Bei der Suche wird das Makro aufgerufen, um die Schraffur der vorherigen Suche zu entfernen und die Formate wieder herzustellen. Teste mal folgende beide Prozeduren:

Sub FindenFaerben()

Dim Such As Variant

Dim arrSuch As Variant

Dim c As Range, rngC As Range

Dim FirstAddress As String

Application.ScreenUpdating = False

With ActiveSheet

   Format

   Such = Application.InputBox("Gib hier deinen Suchbegriff ein" _

      & Chr(10) & " und semikolongetrennt" & Chr(10) & _

      "eine 0 für Suche in ganzer Zelle" _

      & Chr(10) & "eine 1 für Suche in Teil der Zelle", _

      "Suchbegriff", Type:=3)

   If Such = 0 Or Such = "False" Or Such = "" Then Exit Sub

   arrSuch = Split(Such, ";")

   .UsedRange.Copy Sheets("Tabelle2").Range("A1")

   Set c = .UsedRange.Find(arrSuch(0), LookIn:=xlValues, _

      lookat:=IIf(arrSuch(1) = 0, xlWhole, xlPart))

   If Not c Is Nothing Then

      FirstAddress = c.Address

      Do

         With c.Interior

            .Pattern = xlLightUp

            .PatternColorIndex = xlAutomatic

            .ColorIndex = .ColorIndex

         End With

         Set c = .UsedRange.FindNext(c)

      Loop While Not c Is Nothing And c.Address <> FirstAddress

   End If

End With

Application.ScreenUpdating = True

End Sub

Sub Format()

Sheets("Tabelle2").UsedRange.Copy

With Sheets("Tabelle1").UsedRange

   .Interior.Pattern = xlNone

   .PasteSpecial xlPasteFormats

End With

End Sub

Mit freundlichen Grüßen

Claus
War diese Antwort hilfreich?

0 Kommentare Keine Kommentare
Anonym

2014-08-23T12:33:36+00:00

Hallo Steffi,

dann probiers mal so:

Sub FindenFaerben()

Dim Such As Variant

Dim arrSuch As Variant

Dim c As Range, rngC As Range

Dim FirstAddress As String

Application.ScreenUpdating = False

With ActiveSheet

   Format

   Such = Application.InputBox("Gib hier deinen Suchbegriff ein" _

      & Chr(10) & " und semikolongetrennt" & Chr(10) & _

      "eine 0 für Suche in ganzer Zelle" _

      & Chr(10) & "eine 1 für Suche in Teil der Zelle", _

      "Suchbegriff", Type:=3)

   If Such = 0 Or Such = "False" Or Such = "" Then Exit Sub

   arrSuch = Split(Such, ";")

   .UsedRange.Copy Sheets("Tabelle2").Range("A1")

   Set c = .UsedRange.Find(arrSuch(0), LookIn:=xlValues, _

      lookat:=IIf(arrSuch(1) = 0, xlWhole, xlPart))

   If Not c Is Nothing Then

      FirstAddress = c.Address

      Do

         With c.Interior

            .Pattern = xlLightUp

            .PatternColor = RGB(204, 0, 204)

            .ColorIndex = .ColorIndex

         End With

         Set c = .UsedRange.FindNext(c)

      Loop While Not c Is Nothing And c.Address <> FirstAddress

   End If

End With

Application.ScreenUpdating = True

End Sub

Sub Format()

With Sheets("Tabelle1").UsedRange

   If Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row = 1 Then

      .Copy Sheets("Tabelle2").Range("A1")

   Else

      Sheets("Tabelle2").UsedRange.Copy

      .Interior.Pattern = xlNone

      .PasteSpecial xlPasteFormats

   End If

End With

End Sub

Mit freundlichen Grüßen

Claus
War diese Antwort hilfreich?

0 Kommentare Keine Kommentare