leere Zeilen einfuegen

Sub FindValue() Dim c As Range Dim firstAddress As String Dim CurrentSheet As Object With Worksheets(1).Range("A1:A500") Set c = .Find("Total", LookIn:=xlValues, MatchCase:=True) If Not c Is Nothing Then firstAddress = c.Address Do ActiveCell.EntireRow.Insert Set c = .FindNext(c) Loop While Not c Is Nothing End If End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub FindValue() Dim c As Range Dim firstAddress As String Dim CurrentSheet As Object With Worksheets(1).Range("A1:A500") Set c = .Find("Total", LookIn:=xlValues, MatchCase:=True) If Not c Is Nothing Then firstAddress = c.Address Do Rows(c.Row + 1 & ":" & c.Row + 3).EntireRow.Insert Set c = .FindNext(c) Loop While Not c Is Nothing End If End With End Sub

Zu Deiner Datei kann ich nichts schreiben, was wohl daran liegt das ich nicht auf fremde Rechner schaue.Ich baue keine Datei nach.
Sollte die Datei verlinkt werden?
Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten
http://www.ms-office-forum.de/forum/showthread.php?t=322895
ändern.
Bilder lade ich mir nicht runter, da Excel damit nichts anfangen kann.
http://www.excel-ist-sexy.de/bilder-statt-datei/
Hochgeladene Bilder können zwar als solche in Excel importiert werden, sind jedoch bei der Lösung von Problemen nicht sehr hilfreich, da man die eigentlichen Daten nicht ohne große und zeitraubende Umwege direkt in die Tabelle übertragen kann.
Das ist nur meine Meinung zu dem Thema.
http://www.excel-ist-sexy.de/bilder-statt-datei/
Hochgeladene Bilder können zwar als solche in Excel importiert werden, sind jedoch bei der Lösung von Problemen nicht sehr hilfreich, da man die eigentlichen Daten nicht ohne große und zeitraubende Umwege direkt in die Tabelle übertragen kann.
Das ist nur meine Meinung zu dem Thema.
Falls Link nicht ausgeführt wird:
1. Link kopieren
2. rechte Maustaste neues Fenter.
3. Umschaltstaste drücken und Klick auf den Link
4. STRG+ Link mit Maus aktivieren
Gruß Hajo

Sub Unit() Dim X As Range, ct As Integer Set X = Columns("A").Find("Total", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True) If X Is Nothing Then Exit Sub Set X = Range(X, Cells(Rows.Count, 1).End(xlUp)).ColumnDifferences(X) For ct = X.Areas.Count To 1 Step -1 X.Areas(ct).Cells(1).Resize(3).EntireRow.Insert Next End Sub

Sub emptyLines() 'adding empty lines Dim X As Range, ct As Integer Set X = Columns("A").Find("Total", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True) If X Is Nothing Then Exit Sub Set X = Range(X, Cells(Rows.Count, 1).End(xlUp)).ColumnDifferences(X) For ct = X.Areas.Count To 1 Step -1 X.Areas(ct).Cells(1).Resize(3).EntireRow.Insert Next End Sub

Public Sub Leerzeilen() Dim i As Long, raZeilen As Range Application.ScreenUpdating = False With Worksheets("Tabelle1") For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1 If .Cells(i, "A") = "Total" Then If raZeilen Is Nothing Then Set raZeilen = .Cells(i, "A").Offset(1).Resize(3) Else Set raZeilen = Union(raZeilen, .Cells(i, "A").Offset(1).Resize(3)) End If End If Next i End With If Not raZeilen Is Nothing Then raZeilen.EntireRow.Insert End If Set raZeilen = Nothing End Sub

Sub Unit() Const strText As String = "Total" Dim X As Range, ct As Integer Set X = Columns("A").Find(strText, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True) If X Is Nothing Then Exit Sub If WorksheetFunction.CountIf(Columns("A"), strText) = 1 Then X.Offset(1, 0).Resize(3).EntireRow.Insert Else Set X = Range(X, Cells(Rows.Count, 1).End(xlUp)).ColumnDifferences(X) For ct = X.Areas.Count To 1 Step -1 X.Areas(ct).Cells(1).Resize(3).EntireRow.Insert Next End If End Sub

Beliebteste Forumthreads (12 Monate)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread