Bereich zwischen Wörtern ausschneiden

Hallo zusammen,
ich habe leider nichts zu diesem Thema im Forum gefunden und verzweifel grad ein wenig...
ich hoffe ihr könnt mir bei meinem Problem helfen. :)
Ich benötige folgenden Vorgang, falls überhaupt möglich, in VBA:
Das Wort 1 = "Beispiel1" befindet sich immer in Spalte A. Dies soll gesucht werden und der Bereich bis zu Wort 2 = "Beispiel2", welches sich auch immer in Spalte A befindet, markiert, ausgeschnitten und in Tabelle2 in die erste freie Zeile in Spalte A transponiert werden. Und das solange bis eins der beiden Suchbegriffe in Tabelle 1 nicht mehr vorkommt.
Die Wörter 1 und 2 können öfter vorkommen und der Bereich zwischen Wort 1 und Wort 2 kann auch immer unterschiedlich viele Zeilen enthalten. So kann es also sein, dass ich mal nur einen Bereich, mal aber auch mehrere Bereiche habe die in Tabelle 2 transponiert werden sollen, so dass aus der Tabelle 1 Spalte A eine fortlaufende Auflistung in Tabelle 2 entsteht.
Ich bin schon sehr gespannt auf eure Antworten und darauf zu erfahren ob so etwas möglich ist! :)
VG
Jan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Transfere() Dim TB1 As Worksheet, TB2 As Worksheet Dim Sp As Integer, Such1 As String, Such2 As String Dim Anz As Integer, Zvon As Integer, Zbis As Integer, LR As Integer Dim Pfad As String, NeuName As String, WS Set TB1 = Sheets("Tabelle1") Set TB2 = Sheets.Add(after:=Sheets(Sheets.Count)) 'Temporäres Blatt Set WS = WorksheetFunction Sp = 1 'Suchspalte A Pfad = "C:\Temp\" NeuName = "Mängelmeldungen.xlsb" Such1 = "Beispiel 1" Such2 = "Beispiel 2" Do Until WS.CountIf(TB1.Columns(Sp), Such1) = 0 If WS.CountIf(TB1.Columns(Sp), Such2) > 0 Then ' ist Such2 auch vorhanden Zvon = WS.Match(Such1, TB1.Columns(Sp), 0) Zbis = WS.Match(Such2, TB1.Columns(Sp), 0) LR = TB2.Cells.SpecialCells(xlCellTypeLastCell).Row + 1 'Erste freie Zeile 'übertragen TB2.Cells(LR, Sp).Resize(1, Zbis - Zvon - 1).Value = _ WS.Transpose(TB1.Cells(Zvon + 1, Sp).Resize(Zbis - Zvon - 1, 1)) 'Zeilen löschen TB1.Rows(Zvon).Resize(Zbis - Zvon + 1).Delete xlUp Else MsgBox "Fehlendes Ende: " & Such2 End If Loop 'Verschieben in neue Datei TB2.Move 'speichern ActiveWorkbook.SaveAs Filename:=Pfad & NeuName, FileFormat:=xlExcel12 End Sub

Option Explicit Sub Transfere() Dim TB1 As Worksheet, TB2 As Worksheet Dim Sp As Integer, Such1 As String, Such2 As String Dim Anz As Integer, Zvon As Integer, Zbis As Integer, LR As Integer Dim Pfad As String, NeuName As String, WF Set TB1 = Sheets("Tabelle1") Sp = 1 'Suchspalte A Pfad = "C:\Temp\" NeuName = "Mängelmeldungen.xlsb" Such1 = "Beispiel 1" Such2 = "Beispiel 2" Set WF = WorksheetFunction Set TB2 = Sheets.Add(after:=Sheets(Sheets.Count)) Do Until WF.CountIf(TB1.Columns(Sp), Such1) = 0 If WF.CountIf(TB1.Columns(Sp), Such2) > 0 Then 'ist Such2 auch vorhanden Zvon = WF.Match(Such1, TB1.Columns(Sp), 0) Zbis = WF.Match(Such2, TB1.Columns(Sp), 0) 'erste freie Zeileermitteln LR = TB2.Cells.SpecialCells(xlCellTypeLastCell).Row + 1 'übertragen TB2.Cells(LR, Sp).Resize(1, Zbis - Zvon - 1).Value = _ WF.Transpose(TB1.Cells(Zvon + 1, Sp).Resize(Zbis - Zvon - 1, 1)) 'Zählen Anz = Anz + 1 'löschen TB1.Rows(Zvon).Resize(Zbis - Zvon + 1).Delete xlUp Else MsgBox "Fehlendes Ende: " & Such2 Exit Do End If Loop 'Verschieben in neue Datei und speichern If Anz > 0 Then TB2.Move ActiveWorkbook.SaveAs Filename:=Pfad & NeuName, FileFormat:=xlExcel12 Else Application.DisplayAlerts = False TB2.Delete End If MsgBox Anz & " Fundstellen" End Sub

Hallo nochmal.
Dann so...


Option Explicit
Sub Transfere()
Dim TB1 As Worksheet, WB2 As Workbook, TB2 As Worksheet
Dim Sp As Integer, Such1 As String, Such2 As String
Dim Anz As Integer, Zvon As Integer, Zbis As Integer, LR As Integer
Dim Pfad As String, DateiName As String, WF, TMP As Boolean
Application.ScreenUpdating = False
Set TB1 = Sheets("Tabelle1")
Sp = 1 'Suchspalte A
Pfad = "C:\Temp\"
DateiName = "Mängelmeldungen.xlsb"
Such1 = "Beispiel 1"
Such2 = "Beispiel 2"
Set WF = WorksheetFunction
Set WB2 = Workbooks.Open(Filename:=Pfad & DateiName)
Set TB2 = WB2.Sheets(1)
Do Until WF.CountIf(TB1.Columns(Sp), Such1) = 0
If WF.CountIf(TB1.Columns(Sp), Such2) > 0 Then  'ist Such2 auch vorhanden
Zvon = WF.Match(Such1, TB1.Columns(Sp), 0)
Zbis = WF.Match(Such2, TB1.Columns(Sp), 0)
'erste freie Zeile ermitteln
LR = TB2.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
'übertragen
TB2.Cells(LR, Sp).Resize(1, Zbis - Zvon - 1).Value = _
WF.Transpose(TB1.Cells(Zvon + 1, Sp).Resize(Zbis - Zvon - 1, 1))
'Zählen
Anz = Anz + 1
'löschen
TB1.Rows(Zvon).Resize(Zbis - Zvon + 1).Delete xlUp
Else
MsgBox "Fehlendes Ende: " & Such2
Exit Do
End If
Loop
'speichern und schließen
If Anz > 0 Then TMP = True ' =mit Speichern
MsgBox Anz & " Zeilen angefügt"
WB2.Close Savechanges:=TMP
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Bereich zwischen Wörtern ausschneiden

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread