Schlaue Köpfe benötigt! Überschriften kopieren

Forumthread: Schlaue Köpfe benötigt! Überschriften kopieren

10.08.2017 12:24:18

Marie

Hallo Ihr Lieben,
ich benötige mal wieder eure schlauen Köpfe! :-)
Folgendes würde ich gerne realisieren:
Wenn in Spalte A das Wort "xx" vorkommt und somit eine Art Überschfit ist, dann soll die ganze Zeile in spalte C kopiert werden, und zwar für alle Zeilen "yy" bis zur nächsten Überschrift.
Ausgangssituation:
Spalte A: xx und yy
Spalte B: Überschriften und Nr
Spalte C: leer
xx Überschrift A
yy Nr 1
yy Nr 2
yy Nr 3
xx Überschrift B
yy Nr 4
xx Überschrift C
yy Nr 5
yy Nr 6
Soll-Ergebnis:
yy Nr 1 Überschrift A
yy Nr 2 Überschrift A
yy Nr 3 Überschrift A
yy Nr 4 Überschrift B
yy Nr 5 Überschrift C
yy Nr 6 Überschrift C
Ich hoffe, ich konnte es einigermaßen verständlich darstellen! :-)
Danke für Eure Hilfe!!!

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Zeig das doch bitte in einer Beispiel-Mappe...

10.08.2017 13:25:58

Michael
quick and dirty

10.08.2017 14:09:09

KlausF
upps, Korrektur

10.08.2017 14:35:36

KlausF
AW: upps, Korrektur

14.08.2017 10:08:14

Marie
Datei

14.08.2017 14:28:23

KlausF
AW: Schlaue Köpfe benötigt! Überschriften kopieren

10.08.2017 21:50:58

Christian

Zeig das doch bitte in einer Beispiel-Mappe...

10.08.2017 13:25:58

Michael

Hallo Marie,
...mit Ausgangssituation und gewünschtem Ergebnis! Dann ist es leichter nachvollziehbar.
Die Daten an sich kannst Du ruhig wie o.a. beschreiben.
LG
Michael

quick and dirty

10.08.2017 14:09:09

KlausF

Hallo Marie,
quick and dirty:

Sub Aufteilen()
Dim strSearch As String
strSearch = "xx"
Dim lastRow As Long, foundRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Dim rngBereich As Range, rng As Range
Set rngBereich = Range("A1:A" & lastRow)
Application.ScreenUpdating = False
For Each rng In rngBereich
If InStr(rng, strSearch) > 0 Then
foundRow = rng.Row
Range("A" & foundRow).ClearContents
Range("B" & foundRow).Cut Range("C" & foundRow + 1)
End If
Next rng
Set rng = Nothing
Set rngBereich = Nothing
End Sub

Passt's?
Gruß
Klaus

upps, Korrektur

10.08.2017 14:35:36

KlausF

Hallo Marie,
hatte noch etwas vergessen:

Sub Aufteilen()
Dim strSearch As String
strSearch = "xx"
Dim lastRow As Long, foundRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Dim rngBereich As Range, rng As Range
Set rngBereich = Range("A1:A" & lastRow)
Application.ScreenUpdating = False
For Each rng In rngBereich
If InStr(rng, strSearch) > 0 Then
foundRow = rng.Row
Range("A" & foundRow).ClearContents
Range("B" & foundRow).Cut Range("C" & foundRow + 1)
Else
If Not IsEmpty(rng.Offset(1, 0)) Then
If InStr(rng.Offset(1, 0), strSearch) = 0 Then
rng.Offset(1, 2) = Range("C" & foundRow + 1)
End If
End If
End If
Next rng
Set rng = Nothing
Set rngBereich = Nothing
End Sub

Sollte jetzt aber klappen ...
Gruß
Klaus

AW: upps, Korrektur

14.08.2017 10:08:14

Marie

Hallo KlausF!
Ein großes Dankeschön schonmal an dich!
Ich habe den Code wie oben auf mehrere Zellen ausgeweitet. Für die ersten Zeilen funktioniert er, dann stürzt Excel aber irgendwann immer ab.
Die Datei hat ca. 30.000 Zeilen - meinst du, dass das mit der Dateigröße zusammenhängt?
Ich finde nämlich sonst keinen Fehler, und - wie gesagt - für die oberen Zeilen funktioniert es wunderbar!
.....
Range("B" & foundRow).ClearContents
Range("G" & foundRow).ClearContents
Range("H" & foundRow).ClearContents
Range("A" & foundRow).Cut Range("M" & foundRow + 1)
Range("C" & foundRow).Cut Range("N" & foundRow + 1)
Range("D" & foundRow).Cut Range("O" & foundRow + 1)
Range("E" & foundRow).Cut Range("P" & foundRow + 1)
Range("F" & foundRow).Cut Range("Q" & foundRow + 1)
If Not IsEmpty(rng.Offset(1, 0)) Then
If InStr(rng.Offset(1, 0), strSearch) = 0 Then
rng.Offset(1, 2) = Range("M" & foundRow + 1)
End If
End If
End If
Next rng
Set rng = Nothing
Set rngBereich = Nothing
End Sub
Danke und viele Grüße!!

Datei

14.08.2017 14:28:23

KlausF

Hallo Marie,
30.000 Zeilen sollten bei Excel 2010 nicht das Problem darstellen.
Aber ich kann natürlich nicht sehen, was der zusätzliche Code
von Dir wirklich macht. Jedenfalls deuten Deine Zusätze und
Änderungen auf eine andere Datenstruktur hin als in der Frage
angegeben. Bei mir läuft der Code jedenfalls bei über
30.000 Zeilen korrekt in 4 Sekunden durch.
Vorschlag: Erstelle doch mal eine Datei mit ca. 10 bis 15 Datensätzen
(anonymisiert), die die wirkliche Datenstruktur zeigen und Deinem
verändertem Makro. Dann kann ich da heute Abend noch einmal
drüber schauen.
Gruß
Klaus

AW: Schlaue Köpfe benötigt! Überschriften kopieren

10.08.2017 21:50:58

Christian

Hey Marie,
von deiner Ansprache fühle ich mich jetzt micht wirklich angesprochen ;-)
Hier meine Interpretation...:

Sub Ueberschriften()
' Tabellenname ggf. anpassen
With ThisWorkbook.Worksheets("Tabelle1")
Dim strUmarker As String
strUmarker = "xx"
Dim strVmarker As String
strVmarker = "yy"
Dim strTrenner As String
strTrenner = " | "
' Linke oberste Zelle des Datenblocks, ggf. anpassen
Dim rng As Range
Set rng = .Range("A1").CurrentRegion.Resize(, 2)
Dim oRow As Range
For Each oRow In rng.Rows
With oRow
'Debug.Print .Address
Dim strUe As String
If .Cells(1, 1).Value = strUmarker Then
strUe = .Cells(1, 2)
End If
If .Cells(1, 1).Value = strVmarker Then
.Cells(1, 3).Value = _
.Cells(1, 1) & _
strTrenner & _
.Cells(1, 2) & _
strTrenner & _
strUe
End If
End With
Next oRow
End With
End Sub

Viel Spaß beim Ausprobieren,
Christian

Beliebteste Forumthreads (12 Monate)

Schlaue Köpfe benötigt! Überschriften kopieren

Forumthread: Schlaue Köpfe benötigt! Überschriften kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread