Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
960to964
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
960to964
960to964
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Bereich zwischen 2 Worten finden und kopieren

Bereich zwischen 2 Worten finden und kopieren
17.03.2008 09:47:00
Matthias
Hallo zusammen,
habe folgendes Problem:
Habe eine Excel Tabelle mit 3 Sheets: Completed, Implemented & Active.
Auf dem "Active" Sheet sind Daten, welche jeweils durch eine Verbundene Zeile,
nach Active, Completed und Implemented geteilt sind.
Mein Problem ist, das die Daten alle auf einem Sheet stehe, aber getrennt werden
sollen. Im Prinzip müßte mann mit der Find Methode doch den Bereich zwischen
Implemented und Completed auf das Sheet "Implemented und den Bereich nach Completed
auf das Sheet "Completed" kopieren können.
Habe allerdings nur begrenzte Kenntnisse und es hapert noch an der Umsetzung.
Wäre toll wenn mir jemand helfen könnte.
Gruß
Matthias

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bereich zwischen 2 Worten finden und kopieren
17.03.2008 11:04:00
fcs
Hallo Mathias,
?
Auf dem "Active" Sheet sind Daten, welche jeweils durch eine Verbundene Zeile,
nach Active, Completed und Implemented geteilt sind.

? Was meinst du damit?
Lade eine Beispieldatei mit Dummy-Daten hoch, damit man den Datenaufbau erkennt und ggf. systematisch per Makro abarbeiten kann
Gruß
Franz

AW: Bereich zwischen 2 Worten finden und kopieren
17.03.2008 11:57:54
Matthias
Kann mir jetzt jemand helfen?

AW: Bereich zwischen 2 Worten finden und kopieren
17.03.2008 15:26:35
fcs
Hallo mathias,
hier mein Makrovorschlag
Da die verbundene Zellen die Arbeit erschweren werden diese vom Makro in Einzelzellen aufgelöst.
Gruß
Franz

Sub Aufteilen()
Dim wb As Workbook
Dim wsC As Worksheet, wsA As Worksheet, wsI As Worksheet
Dim Spalte As Long
Dim Zeile1 As Long, Zeile2 As Long, Zeile3 As Long, Zelle As Range
Set wb = ActiveWorkbook
Set wsA = wb.Worksheets("Active")
Set wsC = wb.Worksheets("Completed")
Set wsI = wb.Worksheets("Implemented")
wsA.UsedRange.MergeCells = False 'Verbundene Zellen auflösen
'Titelzeilen kopieren
wsA.Range(wsA.Rows(1), wsA.Rows(2)).Copy Destination:=wsC.Cells(1, 1)
wsA.Range(wsA.Rows(1), wsA.Rows(2)).Copy Destination:=wsI.Cells(1, 1)
Application.CutCopyMode = False
'SPaltenbreiten übertragen
For Spalte = 1 To 9
wsC.Columns(Spalte).ColumnWidth = wsA.Columns(Spalte).ColumnWidth
wsI.Columns(Spalte).ColumnWidth = wsA.Columns(Spalte).ColumnWidth
Next
'Implemented übertragen
Set Zelle = wsA.Columns(1).Find(what:="Implemented", LookIn:=xlValues, lookat:=xlPart)
If Zelle Is Nothing Then
MsgBox "Implemented nicht gefunden"
Else
Zeile1 = Zelle.Row
Set Zelle = wsA.Columns(1).Find(what:="Completed", LookIn:=xlValues, lookat:=xlPart)
If Zelle Is Nothing Then
MsgBox "Completed nicht gefunden"
Else
Zeile2 = Zelle.Row
wsA.Range(wsA.Rows(Zeile1 + 1), wsA.Rows(Zeile2 - 1)).Copy _
Destination:=wsI.Cells(3, 1)
End If
End If
'Completed übertragen
Set Zelle = wsA.Columns(1).Find(what:="Completed", LookIn:=xlValues, lookat:=xlPart)
If Zelle Is Nothing Then
MsgBox "Completed nicht gefunden"
Else
Zeile2 = Zelle.Row
Zeile3 = wsA.Columns.Cells(wsA.Rows.Count, 1).End(xlUp).Row
wsA.Range(wsA.Rows(Zeile2 + 1), wsA.Rows(Zeile3)).Copy _
Destination:=wsC.Cells(3, 1)
End If
If Zeile1 > 0 And Zeile3 > 0 Then
'Zeilen von Implemented und Completed löschen
wsA.Range(wsA.Rows(Zeile1), wsA.Rows(Zeile3)).Delete shift:=xlShiftUp
'Zeile mit Active löschen
wsA.Rows(3).Delete shift:=xlShiftUp
End If
End Sub


Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige