Für jede Zeile neues Sheet

Hallo zusammen,
ich habe ein Problem, was ich zum Teil schon mit den Antworten aus dem Forum lösen könnte, aber leider nicht ganz.
Also ich habe im Tabellenblatt mit dem Namen "Maßnahmen" ab der zweiten Zeile Maßnahmen aufgelistet.Die Maßnahmen werden anhand ihrer ID, die in Spalte B steht, unterschieden. In Spalte C steht ein Startdatum und in Spalte D ein Enddatum .
Nun möchte ich für jede ID ein neues Tabellenblatt erstellen -> das löse ich momentan dank " _ https://www.herber.de/forum/archiv/1132to1136/1135807_Fuer_jede_Zeile_neues_Sheet_und_Daten_transponieren.html" so:


Sub DatenpoolSepariertTransponieren()
Dim lngZ As Long
Dim wsDatenpool As Worksheet
'Name des Tabellenblattes, das die Liste enthält - bitte anpassen :
Set wsDatenpool = Worksheets("Abgeschlossene Maßnahmen")
With wsDatenpool
For lngZ = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
Sheets.Add.Name = .Cells(lngZ, 2) 'Name des neuen Blattes aus Spalte A
.Rows(1).Copy
Next
End With
Application.CutCopyMode = False
Set wsDatenpool = Nothing 'Speicher für Variable wieder freigeben
End Sub

Das Problem ist, dass manche Maßnahmen (mit der selben ID) über mehrere Zeilen gehen und deswegen eine Fehlermeldung kommt, da jedes Tabellenblatt unterschiedlich heißen muss (Dopplung). Filtern/Sortieren oder auch doppelte Maßnahmen löschen funktioniert hier vorab leider nicht, da ich gerne auch das Start und das Enddatum in das neue Tabellenblatt kopieren möchte. Allerdings brauche ich nur das erste Startdatum und das letzte Enddatum --> Vllt. nochmal zum Verständnis: Wenn eine Maßnahme mit dem gleichen Namen über 3 Zeilen geht, hat sie 3 Startdaten (Spalte C) und 3 Enddaten (Spalte D).
Excel sollte also "selber erkennen" über wieviele Zeilen die Maßnahme mit der selben ID geht, dann ein neues Tabellenblatt mit der ID als Name erstellen und anschließend das erste Start- und das letzte Enddatum in das entsprechende Tabellenblatt kopieren.
Ich hoffe das war einigermaßen nachvollziehbar erklärt. Ich bin für jeden Hinweis dankbar.
Viele Grüße,
Chris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

if [not(isref(Total!a1))] then sheets.add().name="Total" Function SheetExists(shName As String) As Boolean Dim sh As Worksheet On Error Resume Next Set sh = Sheets(shName) On Error GoTo 0 SheetExists = Not sh Is Nothing End Function

Sub DatenpoolSepariertTransponieren() Dim lngZ As Long Dim Anzahl as long Dim wsDatenpool As Worksheet 'Name des Tabellenblattes, das die Liste enthält - bitte anpassen : Set wsDatenpool = Worksheets("Abgeschlossene Maßnahmen") With wsDatenpool For lngZ = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Sheets.Add.Name = .Cells(lngZ, 2) 'Name des neuen Blattes aus Spalte A .Rows(1).Copy Anzahl = Worksheetfunction.CountIf(.columns(2), .Cells(lngZ, 2)) ActiveSheet.Cells(2, 1) = .Cells(lngZ, 3) 'startdatum ActiveSheet.Cells(3, 1) = .Cells(lngZ + Anzahl - 1) 'Enddatum lngZ = lngZ + Anzahl - 1 Next End With Application.CutCopyMode = False Set wsDatenpool = Nothing 'Speicher für Variable wieder freigeben End Sub

Hi
naja, wenn die Liste sortiert ist, ist es doch einfach.
wenn beispielsweise eine Indexnummer in Zeile 5 beginnt und 3x vorkommt (das wird mit Worksheetfunction.CountIf ermittelt und in der Variable Anzahl gespeichert) dann steht der letzte Eintrag zu diesem Index in Zeile 7 (5 + 3 - 1, bzw erste Zeile + Anzahl - 1)
damit solltst du selber berechnen können, in welcher Zeile der letzte Eintrag steht.
bedenke weiterhin, dass du für Code, den du dir aus dem Internet kopierst, so verantwortlich bist, als hättest du ihn selber geschrieben, insofern warne ich immer davor, Code blind und ohne ihn zu verstehen aus dem Internet zu kopieren.
im Prinzip funktioniert mein Code, der einzige Fehler den ich drin habe ist, dass ich beim Einfügen des Enddatums vergessen habe, die Spalte anzugeben, aus der der Wert gelesen werden soll (Spalte 4).
ActiveSheet.Cells(3, 1) = .Cells(lngZ + Anzahl - 1, 4) 'Enddatum
da ich nicht weiß, wo das Datum eingetragen werden soll, habe ich einfach mal Zelle A3 angenommen, (Cells(3, 1))
das entsprechend anzupasen und die gewünschte Zeilen- und Spaltennummer einzutragen, solltest du selber hinbekommen.
gruß Daniel

Sub test() Dim dicStart As Object Dim dicEnde As Object Dim arr, ID Dim z As Long Dim Überschriften arr = Sheets("Abgeschlossene Maßnahmen").UsedRange.Value Überschriften = Sheets("Abgeschlossene Maßnahmen").UsedRange.Rows(1).Value Set dicStart = CreateObject("scripting.dictionary") Set dicEnde = CreateObject("scripting.dictionary") '--- Start und Enddatum pro ID in Dictionary-Objekt einlesen For z = 2 To UBound(arr, 1) ID = arr(z, 2) If arr(z, 4) > dicEnde(ID) Then dicEnde(ID) = arr(z, 4) If arr(z, 3)

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread