ereich mittels .find auswählen und kopieren

Hallo,
ich bin auf der Suche nach einem Makro das mir meine Tabelle in bestimmte Bereich aufteilt indem es nach wiederkehrenden Werten sucht und dann den Bereich kopiert.
So sieht meine Tabelle aus, etwas verkürzt.
In Spalte N soll nach 1:1 gesucht werden und der Bereich darüber bis hin zur 1. Funstelle inkl. Spalte K und L sollen kopiert werden.
Tabelle1

	J	K	L	M
1	ABC	XYZ		1,1:1
2	ABC	XYZ		1,1:2
3	ABC	XYZ		1,1:3
4	ABC	XYZ		1,1:20
5	ABC	XYZ		1,2:1
6	ABC	XYZ		1,2:20
7	ABC	XYZ		1,3:1
8	ABC	XYZ		1,3:19
9	ABC	XYZ		1,3:20
10	ABC	XYZ		1,4:1
11	ABC	XYZ		1,4:20
12	ABC	XYZ		2,1:1
13	ABC	XYZ		2,1:2
14	ABC	XYZ		2,1:20
15	ABC	XYZ		2,2:1
16	ABC	XYZ		2,2:20
17	ABC	XYZ		2,3:1
18	ABC	XYZ		2,3:20
19	ABC	XYZ		2,4:1
20	ABC	XYZ		2,4:18
21	ABC	XYZ		1,1:1
22	ABC	XYZ		1,1:20
23	ABC	XYZ		1,2:1
24	ABC	XYZ		1,2:20
25	ABC	XYZ		1,3:1
26	ABC	XYZ		1,3:20
27	ABC	XYZ		1,4:1
28	ABC	XYZ		1,4:20
29	ABC	XYZ		2,1:1
30	ABC	XYZ		2,1:20
31	ABC	XYZ		2,2:1
32	ABC	XYZ		2,2:20
33	ABC	XYZ		2,3:1
34	ABC	XYZ		2,3:19
35	ABC	XYZ		2,3:20
36	ABC	XYZ		2,4:1
37	ABC	XYZ		2,4:13

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Es sollte danach also so aussehen.
Tabelle2

ABC

XYZ

1,1:1

ABC

XYZ

2,1:1

ABC

XYZ

1,1:1

ABC

XYZ

2,1:1

ABC

XYZ

1,1:2

ABC

XYZ

2,1:2

ABC

XYZ

1,1:20

ABC

XYZ

2,1:20

ABC

XYZ

1,1:3

ABC

XYZ

2,1:20

ABC

XYZ

1,2:1

ABC

XYZ

2,2:1

ABC

XYZ

1,1:20

ABC

XYZ

2,2:1

ABC

XYZ

1,2:20

ABC

XYZ

2,2:20

ABC

XYZ

1,2:1

ABC

XYZ

2,2:20

ABC

XYZ

1,3:1

ABC

XYZ

2,3:1

ABC

XYZ

1,2:20

ABC

XYZ

2,3:1

ABC

XYZ

1,3:20

ABC

XYZ

2,3:19

ABC

XYZ

1,3:1

ABC

XYZ

2,3:20

ABC

XYZ

1,4:1

ABC

XYZ

2,3:20

ABC

XYZ

1,3:19

ABC

XYZ

2,4:1

ABC

XYZ

1,4:20

ABC

XYZ

2,4:1

ABC

XYZ

1,3:20

ABC

XYZ

2,4:18

ABC

XYZ

2,4:13

ABC

XYZ

1,4:1

ABC

XYZ

1,4:20

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Ideal wäre wenn es in ein neues Tabellenblatt eingefügt würde.
Wie kann ich so etwas realisieren?
Für den Startpunkt kann eine fixe Position (N1) angegeben werden.
Wenn ich wüsste wie, würde ich wie folgt versuchen vorzugehen.
Beginn Bereich 1 = feste Position
Beginn Bereich 2 = erstes auffinden von *,1:1 (Die Suche danach darf erst eine Zeile unterhalb der festen Position aus beginn Bereich 1 anfangen)
Daraus ergibt sich das Ende von Bereich 1 eine Zeile über dem beginn von Bereich 2 ist.
Somit ist Bereich 1 vollständig erfasst und kann kopiert werden.
Danach müsste der Beginn von Bereich 3 bestimmt werden und daraus dann wieder das Ende von Bereich 2.
Wenn nichts mehr gefunden wird ist die letzte Position in der Spalte auch das Ende vom letzten Bereich.
Die Anzahl an Bereich ist nicht limitiert.
Soviel zur Theorie, nur leider habe ich keinen Plan wie ich so etwas in die Praxis umsetze.
Einfache Makro funktionen kann, auch das Umschreiben von bekannten klappt recht gut, aber solch eine Abfrage zu erstellen ist mir noch etwas zu schwer. Sad
Danke für Eure Hilfe.
Gruß
Joker

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub SpaltenTeiler() Dim sKey As Long, sWvon As Long, sWbis As Long, sAb As Long, sZw As Long Dim strK As String, lngZ As Long, arrK, arrW, qz As Long, qc As Long Dim arrE(), zz As Long, zc As Long, kk As Long sKey = 5 ' Schlüssel in Spalte 5 = E strK = ",1:1" ' Trennung vor diesem Text sWvon = 1 ' kopiere Werte von Spalte 1 = A sWbis = 2 ' bis Spalte 2 = B sAb = 17 ' Ausgabe ab Spalte 17 = Q sZw = 1 ' dazwischen jeweils 1 Spalte leer lngZ = Cells(Rows.Count, sKey).End(xlUp).Row arrK = Application.Transpose(Cells(1, sKey).Resize(lngZ)) arrW = Cells(1, sWvon).Resize(lngZ, sWbis + 1 - sWvon) qc = Application.CountIf(Range("E1:E" & lngZ), "*" & strK) ReDim arrE(1 To lngZ, 1 To qc * (sWbis + 2 + sZw - sWvon) - sZw) For zc = 1 To UBound(arrW, 2) arrE(1, zc) = arrW(1, zc) Next zc arrE(1, zc) = arrK(1) zz = 1 zc = 1 For qz = 2 To lngZ If arrK(qz) Like "*" & strK Then zz = 0 zc = zc + sWbis + sZw - sWvon + 2 End If zz = zz + 1 For kk = 1 To UBound(arrW, 2) arrE(zz, zc + kk - 1) = arrW(qz, kk) Next kk arrE(zz, zc + kk - 1) = arrK(qz) Next qz Cells(1, sAb).Resize(UBound(arrE), UBound(arrE, 2)) = arrE End Sub

Option Explicit Public Sub Find_Methode() Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - die Herkunft Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe Dim rZelle As Range ' die Zelle mit dem gefundenen Suchbegriff Dim sFundst As String ' die erste Fundstelle des Suchbegriffs Dim sSuchbegriff As String ' der Suchbegriff Dim lStart As Long ' die Start-Zeile des zu kopierenden Bereichs Dim iSpalte As Integer ' die Ausgabe-Spalte Dim lLetzte As Long ' die letzte belegte Zeile im Quell-Tabellenblatt Set WkSh_Q = ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen! Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle2") ' den Tabellenblattnamen ggf. anpassen! sSuchbegriff = "1:1" lStart = 1 ' der erste zu kopierende Bereich beginnt in Zeile 1 iSpalte = 1 ' die Beginn des ersten zu kopierenden Bereichs Application.ScreenUpdating = False ' kein Bildschirm-Update = kein flackern With WkSh_Q.Columns(14) ' im Quell-Tabellenblatt in der Spalte 14 = N suchen Set rZelle = .Find(What:=sSuchbegriff, LookAt:=xlPart, LookIn:=xlValues, After:=.Cells(. _ Cells.Count)) If Not rZelle Is Nothing Then ' der Suchbegriff wurde gefunden sFundst = rZelle.Address ' die erste Fundstelle merken/speichern Do If Right(rZelle.Value, 3) = sSuchbegriff Then If rZelle.Row 1 Then WkSh_Q.Range(WkSh_Q.Cells(lStart, 11), WkSh_Q.Cells(rZelle.Row - 1, 14)).Copy _ Destination:= _ WkSh_Z.Cells(1, iSpalte) lStart = rZelle.Row iSpalte = iSpalte + 4 End If End If Set rZelle = .FindNext(rZelle) ' den evtl. nächsten Begriff suchen Loop While Not rZelle Is Nothing And rZelle.Address sFundst Else MsgBox "Der Begriff """ & sSuchbegriff & """ wurde nicht gefunden.", _ 48, " Hinweis für " & Application.UserName End If End With lLetzte = WkSh_Q.Cells(WkSh_Q.Rows.Count, 11).End(xlUp).Row WkSh_Q.Range(WkSh_Q.Cells(lStart, 11), WkSh_Q.Cells(lLetzte, 14)).Copy Destination:= _ WkSh_Z.Cells(1, iSpalte) End Sub

Sorry, ich wollte niemanden verärgern.
Es stimmt das ich inzwischen auch im anderen Forum meine Fragen gestellt habe.
Aber beide Fragen standen zu anfang einige Zeit lang nicht in beiden Foren sondern je eine Frage pro Forum.
Hier hatte ich schon öfters mal hilfe erhalten, das andere Forum kannte ich noch nicht und wollte es mal testen.
Nach einiger Zeit habe ich mich dann entschlossen die jeweils fehlende Frage auch zu stellen.
Je mehr User umso mehr Ideen.
Ich kenne die Verwirrungen der beiden Foren nicht. In manchen Foren ist es absolut nicht gewünscht z.B. links zum anderen Forum einzustellen.
Was den vorwurf der doppelten Arbeit angeht so sehe ich dies nicht ganz so.
Egal ob eine Frage in einem oder zwei Foren gestellt ist, es können immer mehrere Personen an einer Lösung arbeiten ohne voneinander zu wissen.
Nachdem ich deine Lösung zum Thema Position erfolgreich umgesetzt hatte und daraufhin die Lösung des Splitens aus dem anderen Forum auch erfolgreich eingebaut habt, habe ich dort sofort gepostet das alles klar ist und ich keine weitere hilfe mehr benötige.
Selbes hatte ich nun auch hier vor.
Leider war aber dann hier schon das Kind in den Brunnen gefallen was mir sehr leid tut.
Mir lag es fern irgend jemanden vor den Kopf zu stoßen.
Ich bin froh das es Foren wie diese gibt bei denen Leute in Ihrer Freizeit anderen bei Ihren Problemen helfen.
Hiermit noch mal in aller Förmlichkeit eine Entschuldigung von mir falls ich jemanden verärgert haben sollte.

Beliebteste Forumthreads (12 Monate)

ereich mittels .find auswählen und kopieren

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread