Anzeige
Archiv - Navigation
1620to1624
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
Inhaltsverzeichnis

Tabelle splitten und gezielt kopieren

Tabelle splitten und gezielt kopieren
26.04.2018 10:14:08
Hans
Hallo liebe Helfer,
schlage mich schon länger mit diesem Problem rum, vielleicht hat ja jemand eine Antwort darauf.
Und zwar möchte ich per Mausklick (via Button Schaltfläche), dass aus der Quelltabelle ("Measures") in die ZielTabellen (zb. "ZDR-004...", Tabellenblatt mit 12 Zeichen) die jeweiligen Zeilen hineinkopiert werden. Das bedeutet, wenn in Spalte G die ersten 12 Zeichen mit dem Tabellenblatt übereinstimmen, soll alles in das stimmige Tabellenblatt kopiert werden. Und die dann auch für mehrere Tabellenblätter.
Die Zieltabellen entstehen, indem ich bei "Übersicht" in Spalte B die Projektnummer eingebe und auf Template erstellen drücke.
Zudem würde ich gern noch etwas weiteres in den Code verankern. Und zwar sobald in Spalte F von "Measures" Milestones steht, sollen die ersten 7 Zeichen der zugehörigen Spalte B ebenfalls in die Zieltabellen kopiert werden.
Ich hoffe das wurde irgendwie klar, falls nicht gerne melden.
Ich benötige es eventuell für meine Bachelorarbeit, daher wende ich mich an euch.
Vielen Dank im Voraus.
LG Hans
https://www.herber.de/bbs/user/121298.xlsm

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabelle splitten und gezielt kopieren
28.04.2018 23:52:56
Dieter
Hallo Hans,
soweit ich deine Anforderung verstanden habe, kannst du das mit dem folgenden Programm machen:
Sub Verteilen()
Dim anfStr As String
Dim anzZDRBlätter As Long
Dim i As Long
Dim letzteZeile As Long
Dim letzteZeileM As Long
Dim vorhandeneZDRBlätter() As String
Dim wb As Workbook
Dim ws As Worksheet
Dim wsM As Worksheet ' Blatt "Measures"
Dim zielZeile As Long
Dim zeileM As Long
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
If Left$(ws.Name, 3) = "ZDR" Then
anzZDRBlätter = anzZDRBlätter + 1
ReDim Preserve vorhandeneZDRBlätter(1 To anzZDRBlätter)
vorhandeneZDRBlätter(anzZDRBlätter) = ws.Name
' Bisherigen Inhalt des ZDR-Blattes löschen
letzteZeile = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If letzteZeile > 1 Then
ws.Rows(2).Resize(letzteZeile - 1).ClearContents
End If
End If
Next ws
' Sätze von Blatt "Measures" in die ZDR-Blätter kopieren
Set wsM = wb.Worksheets("Measures")
letzteZeileM = wsM.Cells(wsM.Rows.Count, "A").End(xlUp).Row
For zeileM = 2 To letzteZeileM
If Len(wsM.Cells(zeileM, "G")) >= 12 Then
anfStr = Left$(wsM.Cells(zeileM, "G"), 12)
For i = 1 To anzZDRBlätter
If anfStr = vorhandeneZDRBlätter(i) Then
Set ws = wb.Worksheets(vorhandeneZDRBlätter(i))
zielZeile = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
wsM.Rows(zeileM).Copy Destination:=ws.Rows(zielZeile)
End If
Next i
End If
Next zeileM
End Sub
Die Anforderung des letzten Absatzes habe ich leider nicht verstanden. Vielleicht kannst du das noch etwas erläutern.
https://www.herber.de/bbs/user/121339.xlsm
Viele Grüße
Dieter
Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige