steh grad auf den Schlauch. Dürfte eigentlich kein großes Problem sein...:)
Habe hier ein Skript, welches mir gleiche Daten von einer Haupttabelle in einzelne Tabellen kopiert.
Beispiel:
Hauptabelle (Spalte1/Zeile1,2,3,4...): Meier, König, Meier, Schuster...
Diesen Namen können auch mehrfach vorkommen und dieser Block von z. B. allen "Meier" soll dann auf das entsprechende Tabelleblatt "Meier" kopiert werden.
Das klappt soweit auch alles prima!
Mein Problem ist, dass die Daten fortlaufend auf die jeweiligen Tabellen
kopiert werden. Mein Wunsch ist es, dass die Daten immer in Zeile 7 bei dem jeweiligen Blatt eingefügt werden.
Ich hab zum näheren Verständnis mal eine Beispieldatei hochgeladen:
https://www.herber.de/bbs/user/38351.xls
Hier schon einmal das Skript:
Option Explicit
Sub VonGesamtNachEinzelnKopieren()
'Initialisieren der Variablen
Dim I&, J&, LZ1&, LS1&, LZ2&, LS2&, a&, x&
Dim Ws1 As Worksheet
Set Ws1 = Sheets(1) 'Haupttabelle
LZ1 = GetLastRow(Ws1) 'Letzte Zelle mit Daten ermitteln
LS1 = GetLastCol(Ws1) ' Letzte Spalte mit Daten ermitteln
I = 1 ' Zellen, die durchsucht werden sollen
x = 7 'Einfügezelle
Do While I < LZ1
I = I + 1 'Zähler zum Vergleichen der Daten in der Haupttabelle
For J = 1 To LS1
For a = 2 To Sheets.Count - 1
If Ws1.Cells(I, 1) = Sheets(a).Range("A1") Then
'vergleicht den Wert auf jeden einzelnen Tabellenblatt, mit den Werten aus der Haupttabelle
Sheets(a).Cells(x, J) = Ws1.Cells(I, J) 'Gleiche Daten von Gesamt nach Einzeln kopieren
End If
Next a
Next
x = x + 1
Loop
Set Ws1 = Nothing
'Es fehlt: Wie setzt man den Zähler x wieder auf 0 bzw., dass die Einfügezeile auf jeden Tabellenblatt "Zeile 7" ist?!?!?
End Sub
Function GetLastRow(Ws As Worksheet) As Long
GetLastRow = Ws.Range("A65536").End(xlUp).Row
End Function
Function GetLastCol(Ws As Worksheet) As Long
GetLastCol = Ws.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Sub NamenFürEinzelneBlätterAnlegen()
Dim I As Integer
For I = 2 To Sheets.Count - 1
Sheets(I).Range("A1") = Sheets(I).Name
Next I
End Sub
Wäre nett, wenn mir jemand helfen könnte.
Gruß doey