Automatische Zuordnung über mehrere WKS
24.03.2020 13:51:03
Nina
ich sitze seit einigen Stunden an einem Makro und komme nicht mehr weiter.
Ich habe folgende Situation: In der Zelle C1 des worksheets "TLN" kann die "Anzahl der Sessions" eingetragen werden. Es werden dann genauso viele worksheets erstellt (session 1, session 2 ... session n) und im worksheet "TLN" entsprechend viele Spalten mit dem Namen session 1, session 2 usw. benannt. Das funktioniert auch alles echt super. Hier der Code:
Public Sub Worksheet_Change(ByVal Target As Range)
Dim anzahl As Long
Dim wks As Worksheet
If Target.Address = "$C$1" Then
Range("C3:AAA3").Clear
Application.DisplayAlerts = False
For Each wks In ThisWorkbook.Sheets
If UCase(wks.Name) "TLN" And _
LCase(wks.Name) "session 1" Then wks.Delete
Next
Application.DisplayAlerts = True
For anzahl = 1 To Range("C1").Value - 1
Cells(3, anzahl + 2) = "session " & anzahl + 1
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "session " & anzahl + 1
Worksheets("TLN").Activate
Next
End If
End Sub
Und jetzt zu meinem Problem:
In Spalte A des Worksheets "TLN" stehen Teilnehmer, die manuell eingetragen werden und schließlich einen Buchstaben (H oder a bis g) pro Session zugeordnet bekommen (alles manuelle Eingabe)
Bsp. 2 sessions
A4 = Teilnehmer 1; B4 = a; C4 = b
A5 = Teilnehmer 2; B5 = a; C5 = a
A6 = Teilnehmer 3; B6 = b; C6 = a
Nun gibt es die Registerkarte session 1, die wie folgt aussehen soll:
A1 = "a" (Überschrift) ; B1 = "b"
A2 = TLN 1 ; B2 = TLN 3
A3 = TLN 2
Das soll automatisch über alle Registerkarten passieren.
Hier der erste Teil des Codes:
Private Sub btnZUORDNEN_Click()
Dim wks As Worksheet
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Dim s() As Variant 'Spalten-Buchstaben Ziel
Dim z As Long 'Zeile Quelle
Dim i As Integer 'Spalte Quelle
i = 2
For Each wks In ActiveWorkbook.Sheets
If UCase(wks.Name) "TLN" Then
'Überschrift einfügen und Spalten erstellen
Worksheets(wks.Name).Range("A1") = wks.Name
Worksheets(wks.Name).Range("A1").Font.Bold = True
Worksheets(wks.Name).Range("A1").Font.Size = 14
Worksheets(wks.Name).Columns("A:A").AutoFit
Worksheets("session 1").Range("A3:P3").Copy _
Destination:=Worksheets(wks.Name).Range("A3")
'Teilnehmer hinzufügen
Set wksZiel = wks.Name
Set wksQuelle = Worksheets("TLN")
s = Array("A", "B", "C", "D", "E", "F", "G", "H")
With wksQuelle
For z = 4 To .Cells(Rows.Count, i).End(xlUp).Row
Next z
End With
i = i + 1
End If
Next wks
End Sub
Ich würde mich sehr freuen, wenn mir jemand weiterhelfen kann.
Vielen lieben Dank im Voraus & LG Nina