Schlaue Köpfe benötigt! Überschriften kopieren

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

22.08.2017 09:44:04

Marie

Hallo KlausF,
über das Anwortformular konnte ich deinen Eintrag leider nicht mehr finden.
Du hattest mich um eine Beispieldatei gebeten -
entschuldige, dass ich jetzt erst antworte, aber ich war im Urlaub!
https://www.herber.de/bbs/user/115625.xlsx
Hier findest du eine Bespieldatei.
Die Farben zeigen, welche Information an welche Stelle eingefügt werden soll.
Danke vielmals für eine Hilfe!!!

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

22.08.2017 09:46:31

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

22.08.2017 09:52:27

Marie
?

22.08.2017 14:39:33

KlausF
AW: ?

22.08.2017 20:13:06

Piet
AW: ?

23.08.2017 08:51:06

Marie
Code neu

23.08.2017 12:45:42

KlausF
AW: Code neu

24.08.2017 08:56:38

Marie
AW: Code neu

24.08.2017 10:30:28

Marie
AW: Code neu

24.08.2017 13:51:21

KlausF

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

22.08.2017 09:46:31

Hola,
der wird schon im Archiv sein. Verlinke doch bitte den Archivbeitrag in diesem Thread.
Gruß,
steve1da

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

22.08.2017 09:52:27

Marie

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
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!!
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

22.08.2017 14:39:33

KlausF

Hallo Marie,
die Datei hat weder etwas mit Deiner Ausgangsfrage zu tun:
https://www.herber.de/forum/archiv/1572to1576/t1573672.htm#1573672
noch mit Deiner eigenständigen Code-Erweiterung:
https://www.herber.de/forum/archiv/1572to1576/t1573672.htm#1574333
Ehrlich gesagt ist mir absolut unklar was Du eigentlich wirklich willst.
Erstelle mal auf einer Seite die Ausgangsdaten und auf einer zweiten Seite
das Wunschergebnis (mit unterschiedlichen Texten).
Ich stelle mal auf offen. Für Alle.
Gruß
Klaus

AW: ?

22.08.2017 20:13:06

Piet

Hallo
ich sehe eine Beispieldatei aber ohne Code. Wie soll man da nachvollziehen ab wo er abstürzt?
mfg Piet

AW: ?

23.08.2017 08:51:06

Marie

Hallo Klaus,
oh man, im erklären bin ich anscheinend nicht besonders gut ;-)
Hier nochmal eine neue Datei mit Code.
Auf der ersten Seite ist die Ausgangssituation. Sheet2 zeigt, wie es dann aussehen soll.
https://www.herber.de/bbs/user/115647.xlsm
Wenn der Begriff "APO" in Spalte A steht, dann sollen alle Angaben dieser Zeile ausgeschnitten und ab Spalte M eine Zeile darunter wieder eingefügt werden.
Mit dem jetzigen Code stürzt Excel immer ab.
Danke für deine Geduld!
Sonnige Grüße
Marie

Code neu

23.08.2017 12:45:42

KlausF

Hallo Marie,
probier mal:

Sub APOinSpalteM()
Dim strSearch As String
strSearch = "APO"
Dim i As Long
Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To lastRow
If Range("A" & i) = strSearch Then
Range("A" & i & ":F" & i).Cut Range("M" & i + 1)
Range("H" & i).Cut Range("S" & i + 1)
End If
Next i
End Sub

Gruß
Klaus
PS. der alte Code hätte eigentlich auch laufen müssen

AW: Code neu

24.08.2017 08:56:38

Marie

Guten Morgen Klaus,
danke für deine schnelle Antwort!
Der Code klingt 100&ig plausibel - Excel sieht das wohl leider anders.
Er funktioniert ungefähr bis zu Hälfte der Datei und macht auch genau das was er machen soll.
Dann kommt aber sofort "Not Responding" und Excel stürzt ab.
Ich verstehe es nicht...
Trotzdem vielen vielen Dank für deine Unterstützung!!
Liebe Grüße

AW: Code neu

24.08.2017 10:30:28

Marie

Hallo Klaus,
ich habe es mit .copy probiert und endlich läuft es einwandfrei!
Mein PC ist wohl nicht der leistungsstärkste ;-)
Danke dir nochmal und lieben Gruß

AW: Code neu

24.08.2017 13:51:21

KlausF

Hallo Marie,
ich habe auch Office XP und bei mir läuft alles wie es sein soll.
Na ja, Ende gut, Alles gut.
Danke für Deine Rückmeldung.
Gruß
Klaus

Beliebteste Forumthreads (12 Monate)

Schlaue Köpfe benötigt! Überschriften kopieren

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

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread