Live-Forum - Die aktuellen Beiträge
Datum
Titel
24.04.2024 14:48:50
"Eingabefeld" zwischen zwei Zeilen geht nicht weg.
24.04.2024 14:40:10
Zeilenumbrüche in Textbox zählen
24.04.2024 14:06:20
Gesamte Column löschen, wenn Column-Bereich leer
24.04.2024 13:44:05
Bezeichnung Tabellenblatt aus Zelle für Formel auslesen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1540to1544
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1540to1544
1540to1544
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

for each

for each
14.02.2017 15:14:34
Berndt
Hallo Leute,
ich suche einen Programmcode der folgendes kann.
für jede Zeile in der in Spalte H ein Text steht (Achtung: kein #NV), setze mir diese Zeile in roter Schrift und füge über diese Zeile 2 Leerzeilen ein.
Ich hoffe ihr könnt behilflich sein.
VG Berndt

27
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
vorschlag
14.02.2017 15:58:03
Max2
Hallo, ist nicht getestet aber sollte funktionieren...

lzeile = .Cells(.rows.count, 8).End(xlUp).Row
Set rng = .Range(.Cells(1, 8), .Cells(lzeile, 8))
For Each c In rng
If c.Value  "#NV" And c.Value  "" Then
c.Font.Color = RGB(255, 0, 0)
c.Offset(1)EntireRow.Insert
c.Offset(1)EntireRow.Insert
End If
Next c

vorschlag (was vergessen sorry)
14.02.2017 15:59:27
Max2
statt 

c.Offset(1) --> c.Offset(-1)

AW: vorschlag (was vergessen sorry)
14.02.2017 16:22:56
Berndt
Danke für deine Hilfe,
hab das Makro etwas erweitert.
Sub Makro2()
lzeile = Sheets("Auswertung BW-Version Bestand").Cells(.Rows.Count, 8).End(xlUp).Row
Dim t0 As Single
t0 = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Sheets("Auswertung BW-Version Bestand").Range(.Cells(1, 8), .Cells(lzeile, 8))
For Each c In Rng
If c.Value  "#NV" And c.Value  "" Then
c.Font.Color = RGB(255, 0, 0)
c.Offset(-1).EntireRow.Insert
c.Offset(-1).EntireRow.Insert
End If
Next c
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (Timer - t0) / 60 & " min"
End Sub
Allerdings stoppt der Code schon beim fett markierten ("Fehler beim kompilieren: Unzulässiger oder nicht ausreichend definierter Verweis). Dachte eigentlich, dass ich mit meinem Sheets ("...") ausreichend definiert habe.
Anzeige
AW: vorschlag (was vergessen sorry)
14.02.2017 16:34:10
UweD
Hallo
Dachte eigentlich, dass ich mit meinem Sheets ("...") ausreichend definiert habe.
leider nicht.
lzeile = Sheets("Auswertung BW-Version Bestand").Cells(Sheets("Auswertung BW-Version Bestand").Rows.Count, 8).End(xlUp).Row
oder 
with Sheets("Auswertung BW-Version Bestand")
.Cells(.Rows.Count, 8).End(xlUp).Row
end with

teilweise Fehler erkannt
14.02.2017 16:35:05
Berndt
okay. es waren die Punkte. for Row und Cells.
jetzt spinnt er allerdings bei c.Offset(-1).EntireRow.Insert rum.
Sub Makro2()
lzeile = Sheets("Auswertung BW-Version Bestand").Cells(Rows.Count, 8).End(xlUp).Row
Dim t0 As Single
t0 = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Sheets("Auswertung BW-Version Bestand").Range(Cells(1, 8), Cells(lzeile, 8))
For Each c In Rng
If c.Value  "#NV" And c.Value  "" Then
c.Font.Color = RGB(255, 0, 0)
c.Offset(-1).EntireRow.Insert
c.Offset(-1).EntireRow.Insert
End If
Next c
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (Timer - t0) / 60 & " min"
End Sub

Anzeige
Eine Möglichkeit, ...
14.02.2017 16:36:18
Luc:-?
…Berndt: 
Sub InsBefText()
Const adRelSp$ = "H:H"
Dim xZ As Range, relSp As Range
With ActiveSheet
Set relSp = Intersect(.Range(adRelSp), .UsedRange)
Debug.Print relSp.AddressLocal(0, 0)
End With
For Each xZ In relSp
If WorksheetFunction.IsText(xZ) And xZ.Font.Color  vbRed Then
xZ.Font.Color = vbRed
With xZ.EntireRow
.Insert xlShiftDown: .Insert xlShiftDown
End With
End If
Next xZ
End Sub
Feedback nicht unerwünscht! Gruß, Luc :-?
Besser informiert mit …
Anzeige
JA, ABER
14.02.2017 16:45:37
Berndt
Danke derine Möglichkeit funktioniert gut.
Sub Makro2()
Const adRelSp$ = "H:H"
Dim xZ As Range, relSp As Range
t0 = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheets("Auswertung BW-Version Bestand")
Set relSp = Intersect(.Range(adRelSp), .UsedRange)
Debug.Print relSp.AddressLocal(0, 0)
End With
For Each xZ In relSp
If WorksheetFunction.IsText(xZ) And xZ.Font.Color  vbRed Then
xZ.Font.Color = vbRed
With xZ.EntireRow
.Insert xlShiftDown: .Insert xlShiftDown
End With
End If
Next xZ
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (Timer - t0) / 60 & " min"
End Sub
Jedoch. Bei 12.888 Zeilen, in denen dieses Makro eigentlich was machen sollte, dauert dies ewig.
Gibt es optimierungen für große Datensätze.
Anzeige
Die Debug.Print-Zeile löschen oder auskommen-...
14.02.2017 17:13:26
Luc:-?
…tieren (hatte ich vergessen), Berndt;
dauert aber deshalb lange, weil die eingeschobenen Zeilen ab spätestens 2.Einschub mit in die Über­prüfung ein­gehen. Die Lauf­Va­riable lässt sich auch nicht durch ein entsprd Set xZ = xZ.Offset(2, 0) beeindrucken, sondern macht in der Folge­Zeile des urspüngl xZ, also auf der 2.LeerZeile, weiter. Aber wenigstens läuft sie wohl auch bei dir bis zum Ende, obwohl der Bereich zwi­schen­durch ja größer wird.
Wenn man schneller sein will, muss man die TextZellen separat feststellen und dabei ihre Position (ab der 2.) jeweils um die bis dort noch einzu­schie­benden Zeilen korri­gieren. Dann kann man gezielt genau vor diesen Positionen 2 LeerZeilen einfügen.
Luc :-?
Anzeige
AW: Die Debug.Print-Zeile löschen oder auskommen-...
15.02.2017 08:46:42
Berndt
Vielen Dank für deine Hilfe. Es funktioniert wiegesagt.
allerdings benötigt das Makro auch mit auskommentieren der debug zeile immernoch größer 30 min. und ich musste abbrechen. :-(
AW: JA, ABER
14.02.2017 17:37:30
Daniel
Hi
ja, gibt es.
man sortiert die Leerzeilen ein.
im Sortieren ist Excel sehr schnell.
Sub Leerzeilen()
With ActiveSheet.UsedRange
With .Columns(.Columns.Count + 1).Resize(, 2)
.Columns(1).Formula = "=Row()"
.Columns(2).FormulaR1C1 = "=IF(ISTEXT(RC8),ROW()-0.5,""xxx"")"
.Formula = .Value
.Columns(2).Copy
.Offset(.Rows.Count).Resize(.Rows.Count * 2, 1).PasteSpecial xlPasteValues
End With
End With
With ActiveSheet.UsedRange
.Sort key1:=.Cells(1, .Columns.Count - 1), order1:=xlAscending, Header:=xlYes
.Columns(.Columns.Count - 1).Resize(, 2).ClearContents
Intersect(.Columns(8).SpecialCells(xlCellTypeConstants, 2).EntireRow, .Cells).Font.Color =  _
vbRed
End With
End Sub
Gruß Daniel
Anzeige
AW: JA, ABER
15.02.2017 08:53:13
Berndt
Hallo, Danke für deine Hilfe. Deine Lösung scheint vielversprechend zu sein.
Jedoch bricht das Makro ab bei .Offset(.Rows.Count).Resize(.Rows.Count * 2, 1).PasteSpecial xlPasteValues.
Woran liegt das?
VG Berndt
AW: JA, ABER
15.02.2017 09:26:40
Daniel
Hi
es könnte sein, dass dein genutzter Zellbereich zu groß ist (vielleicht eine ungeschickte Formatierung). Prüfe mal, welche Zelle selektiert wird, wenn du STRG+ENDE drückst.
diese Zelle darf erst bei einem drittel der zur verfügung stehenden Zeilen stehen.
oder probiers mal so, das ermittelt die tatsächlich genutzten Zeilen auf eine etwas andere Methode.
auch werden am ende nur die tatsächlich benötigten Werte für die Leerzeilen hinzugefügt:
Sub Leerzeilen()
With Intersect(ActiveSheet.UsedRange, Range("1:" & Cells(Rows.Count, 8).End(xlUp).Row))
With .Columns(.Columns.Count + 1).Resize(, 2)
.Columns(1).Formula = "=Row()"
.Columns(2).FormulaR1C1 = "=IF(ISTEXT(RC8),ROW()-0.5,""xxx"")"
.Formula = .Value
.Columns(2).SpecialCells(xlCellTypeConstants, 1).Copy
.Cells(1, 1).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
.Cells(1, 1).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
End With
End With
With ActiveSheet.UsedRange
.Sort key1:=.Cells(1, .Columns.Count - 1), order1:=xlAscending, Header:=xlYes
.Columns(.Columns.Count - 1).Resize(, 2).ClearContents
Intersect(.Columns(8).SpecialCells(xlCellTypeConstants, 2).EntireRow, .Cells).Font.Color =  _
_
vbRed
End With
End Sub
Gruß Daniel
Anzeige
9,1 Min...es funzt
15.02.2017 10:48:23
Berndt
Also ich habe das neue Makro von dir jetzt getestet und muss sagen, dass ich mich freue.
ich komme auf eine Zeit von 9,1 min.
Dies kann durchaus gewährleistet werden.
Vielen Dank erstmal.
LG Berndt
AW: Variante mit SpecialCells
15.02.2017 02:22:18
littletramp
Hallo Berndt
Hier eine Variante mit SpecialCells und Durchlauf der Zeilen von unten nach oben.
Beachte, dass es mit SpecialCells 2 Varianten gibt um die Textzellen zu ermitteln:
- Variante 1: Der Text wurde mittels Formel einfügt -> Type:=xlCellTypeFormulas
- Variante 2: Der Text wurde in die Zelle eingegeben -> Type:=xlCellTypeConstants
Du musst also ev. für Type die andere Konstante einfügen.

Sub Test()
Dim rngTextRows As Range, rngRow As Range
Dim r As Long, maxRow As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Alle Zeilen mit Textzellen ermitteln
Set rngTextRows = Tabelle1.Columns(8).SpecialCells( _
Type:=xlCellTypeFormulas, Value:=xlTextValues).EntireRow
' Schriftfarbe rot
rngTextRows.Font.Color = vbRed
' Leerzeilen einfügen
maxRow = Tabelle1.Cells(Rows.Count, 8).End(xlUp).row
For r = maxRow To 1 Step -1
Set rngRow = Tabelle1.Rows(r)
If Not Intersect(rngRow, rngTextRows) Is Nothing Then
rngRow.Insert Shift:=xlDown
rngRow.Insert Shift:=xlDown
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Gruss Markus
Anzeige
Danke, aber...
15.02.2017 08:44:26
Berndt
Vielen Dank für deine Hilfe. Es funktioniert.
Nur gibt es das Problem, dass es bei 600.000 Datensätzen zu lang dauert.
Ich hab nach 30 min. abgebrochen. :-(
AW: Danke, aber...
15.02.2017 10:23:33
littletramp
Hallo Berndt
Ups, 600'000 Zeilen, habe ich das irgendwo übersehen?
Du weisst, dass es nur ca. 1 Mio Zeilen gibt. Wenn also bei jeder 3. Datenzeile 2 Leerzeilen eingefügt werden, so hast du 1 Mio Zeilen erreicht!
Ich habe so mit 5000 Zeilen gerechnet, und damit auf einem i3 getestet, und da war die Dauer noch annehmbar.
Da die Zeit durch das Einfügen der Leerzeilen verbraucht wird, werde ich noch mit Daniels Tipp "man sortiert die Leerzeilen ein. im Sortieren ist Excel sehr schnell" , noch einen Turbo einbauen :-)
Bin momentan noch an was anderem, versuche aber es bis spätestens 13:00 hier zu posten. Am Nachmittag bin ich auswärts.
Gruss Markus
Anzeige
AW: Danke, aber...
15.02.2017 10:34:56
Daniel
Hi
bei dieser Datenmenge besser so:
Sub Leerzeilen()
Dim Rx As Range
Dim R1 As Range
Dim R2 As Range
Set Rx = Intersect(ActiveSheet.UsedRange, Range("1:" & Cells(Rows.Count, 8).End(xlUp).Row))
Set Rx = Rx.Resize(, Rx.Columns.Count + 2)
Set R1 = Rx.Columns(Rx.Columns.Count - 1)
Set R1 = R1.Offset(1, 0).Resize(R1.Rows.Count - 1)
Set R2 = Rx.Columns(Rx.Columns.Count)
Set R2 = R2.Offset(1, 0).Resize(R2.Rows.Count - 1)
R1.Formula = "=Row()"
R2.FormulaR1C1 = "=IF(ISTEXT(RC8),ROW()-0.5,""xxx"")"
With Range(R1, R2)
.Copy
.PasteSpecial xlPasteValues
End With
Rx.Sort key1:=R2, order1:=xlAscending, Header:=xlYes
With R2.SpecialCells(xlCellTypeConstants, 1)
If (R1.Cells.Count + R2.Cells.Count * 2 + 1) > ActiveSheet.Rows.Count Then
MsgBox "Zu viele Zeilen"
Rx.Sort key1:=R1, order1:=xlAscending, Header:=xlYes
Range(R1, R2).EntireColumn.Delete
Exit Sub
End If
Intersect(Rx, .EntireRow).Font.Color = vbRed
.Copy
R1.Cells(1, 1).End(xlDown).Offset(1, 0).Resize(.Rows.Count * 2).PasteSpecial xlPasteValues
End With
Rx.EntireColumn.Sort key1:=R1, order1:=xlAscending, Header:=xlYes
Range(R1, R2).EntireColumn.Delete
End Sub
dauert bei mir für 600.000 Zeilen 12 Sekunden.
Dieser Code ist darauf ausgelegt, dass die erste Zeile eine Überschriftenzeile ist.
Gruß Daniel
"Zu viele Zeilen"
15.02.2017 11:02:03
Berndt
Also hier stoppt das Makro weil "Zu viele Zeilen".
Ich hab mal meine Tabelle durchgefiltert.
Von den ~600.000 Datensätzen habe ich nur ca. 2,3%, weilche kein #NV haben bzw. für die die 2 Zeilen eingefügt werden müssten.
AW: "Zu viele Zeilen"
15.02.2017 11:15:08
EtoPHG
Hallo Berndt,
...von den ~600.000 Datensätzen habe ich nur ca. 2,3%, welche kein #NV haben...
Folglich kommst du nach Adam Riese auf ca. 1,8 Millionen Zeilen!!
Excel kann 1,04 Millionen Zeilen in einem Tabellenblatt haben.
Also los mit Aufteilen des Datenbestands ;-)
Gruess Hansueli
AW: "Zu viele Zeilen"
15.02.2017 11:20:11
Daniel
HI Hanusueli
2,3% von 600000 sind 13.800 macht 27.600 Zeilen macht in Summe 627.600 Zeilen
wie kommst du auf die 1,8 Mio?
Gruß Daniel
Ich stimme Daniel zu
15.02.2017 11:41:48
Berndt
*
AW: "Zu viele Zeilen"
15.02.2017 11:16:24
Daniel
sorry noch ein Fehler drin.
die Prüfung muss natürlich lauten:
If (R1.Cells.Count + .Cells.Count * 2 + 1) > ActiveSheet.Rows.Count Then
gruß Daniel
AW: "Zu viele Zeilen"
15.02.2017 12:46:00
Berndt
Also ich komme bei deiner Variante auf 11,2 Min. Im Vergleich ist dein Makro von vorhin mit 9,1 min. nocht effizienter:
Sub Leerzeilen()
With Intersect(ActiveSheet.UsedRange, Range("1:" & Cells(Rows.Count, 8).End(xlUp).Row))
With .Columns(.Columns.Count + 1).Resize(, 2)
.Columns(1).Formula = "=Row()"
.Columns(2).FormulaR1C1 = "=IF(ISTEXT(RC8),ROW()-0.5,""xxx"")"
.Formula = .Value
.Columns(2).SpecialCells(xlCellTypeConstants, 1).Copy
.Cells(1, 1).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
.Cells(1, 1).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
End With
End With
With ActiveSheet.UsedRange
.Sort key1:=.Cells(1, .Columns.Count - 1), order1:=xlAscending, Header:=xlYes
.Columns(.Columns.Count - 1).Resize(, 2).ClearContents
Intersect(.Columns(8).SpecialCells(xlCellTypeConstants, 2).EntireRow, .Cells).Font.Color =   _
_
_
vbRed
End With
End Sub
Vielen Dank für die Hilfe im übrigen
AW: "Zu viele Zeilen"
15.02.2017 12:50:11
Daniel
naja, bei mir liegt die Laufzeit im Bereich von 12 Sekunden bei 10 Spalten und 600.000 Zeilen.
hast du noch Eventmakros am laufen oder Formeln?
Gruß Daniel
ich habs...Thema abgehakt...DANKE
15.02.2017 13:40:18
Berndt
Also ich habe jetzt nochmal geschaut.
Ich hätte euch vll. sagen sollen, dass ich in Spalte 8 in jeder Zeile einen SVerweis drinnen habe (also 600.000 mal). Noch dazu habe ich in anderen Spalten anderere Funktionen (z.B. Verketten).
Also kann ich abschließend sagen:
Mit Formeln: ~9 min
ohne Formeln: 6 sek. :-)
Da mach ich einfach die Formeln vorher weg, bevor ich das Makro starte.
Sorry für die unterschlagene essentielle Information.
Danke für die Rückmeldung
15.02.2017 14:57:56
littletramp
*
Ja, essenziell, denn ursprünglich hatten wohl ...
15.02.2017 16:40:38
Luc:-?
…die meisten AWer an Primärdaten gedacht, Berndt,
und immerhin ist das, was man in deinem Fall (Blatt mit Fmln) tun muss, schon überaus häufig im Forum beschrieben worden. Das Archiv ist also voll von derartigen Vorschlägen:
• Berechnung temporär auf manuell stellen (auch gern im PgmCode)!
• EreignisReaktion temporär abschalten (nur bei entsprd Pgmm u. nur im PgmCode)!
• BildschirmAktualisierung temporär abschalten (nur im PgmCode)!
Dann wäre es uU auch nicht erforderlich gewesen, die Fmln zu entfernen.
Luc :-?

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige