suchen und kopieren mal anders

[Dedl]

Hallo liebe Mitglieder,

als Dummy was Excel VBA angeht würde ich mich über eure Hilfe freuen. Folgendes Problem;

Eine Tabelle enthält sehr viele Einträge (über 15000 Zeilen).
Nach unregelmäßig vielen Zeilen gibt es jeweils einen Ergebnisblock, in diesem steht in Spalte "B" immer das Wort "Mittelwert" und rechts daneben und in den 2 Zeilen darunter die Einzelwerte.

Nun soll nach dem Wort "Mittelwert" in Spalte "B" gesucht werden, die Werte daneben und in den 2 Zeilen darunter (Bereich B.. bis E..) in ein anders Blatt ZEILENWEISE (also alles in einer Zeile nebeneinander aufgeführt werden. In Spalte "A" soll dann noch die Stadt aus Spalte "H" und der Straßenname aus Spalte "G" der Quelltabelle stehen.

Das so oft, bis die Quelltabelle bis zum Ende durchgesucht wurde.

Eine Beispieldatei (mit wenigen Demo Daten) füge ich bei.

  Demodatei Strassenauswertung.xlsx (Größe: 36,86 KB / Downloads: 6)

Hier ein Screenshot mit den Zellen die benötigt werden farbig hinterlegt:
   
ich wäre wirklich sehr dankbar für eure Unterstützung und sage schon mal DANKE!

Viele Grüße
Detlef

[rate mit]

Hallo,

anbei mein Vorschlag...

[Fennek]

Hallo,

zu spät, aber trotzdem:

Code:

Sub F_en()
Dim Qu As Worksheet, Zi As Worksheet, rng As Range, Adr As String
Set Qu = Sheets("Quelltabelle"): Set Zi = Sheets("Zieltabelle")

r = 1
With Qu.Columns(2)
Set rng = .Find("Mittelwert", , xlValues, xlPart)
Adr = rng.Address
Do
    r = r + 1
    Zi.Cells(r, 1) = rng.Offset(, 6)
    Zi.Cells(r, 2) = rng.Offset(, 5)
    Zi.Cells(r, 3) = rng.Offset(, 1)
    Zi.Cells(r, 4) = rng.Offset(1, 3)
    Zi.Cells(r, 5) = rng.Offset(, 3)
    Zi.Cells(r, 6) = rng.Offset(1, 1)
    Zi.Cells(r, 7) = rng.Offset(2, 1)
    
    Set rng = .FindNext(rng)
Loop Until rng.Address = Adr
End With

Set Zi = Nothing
Set Qu = Nothing
Set rng = Nothing
End Sub

mfg

[Dedl]

Danke für die rasend schnelle Antwort. Sieht prima aus, aber ich bräuchte bitte den Code, denn das war nur eine Demo, die Original hat 14.000 Zeilen

Ich wünschte, ich könnte so etwas auch

Also, nochmals ganz herzlichen Dank im Voraus,

liebe Grüße
Detlef

---

Hallo Fenek,

supi, genau wie ich es brauchte! Ganz toll! Dauert etwas aber das ist egal, ich hoffe, das Script kommt auch mit der Originaldatei mit ihren mehreren tausend Einträgen zurecht.

Ganz, ganz lieben Dank!

[rate mit]

Ich wünschte, ich könnte so etwas auch

Excel – Listen dynamisch per Funktion filtern – AGGREGAT und FINDEN | at Excel-Blog - Andreas Thehos (thehosblog.com)

[Dedl]

Genial, auf die Idee bin ich nie gekommen, manches kann so einfach sein, Danke nochmal