Tabellenblattname aus Zelle
Gisela
vor einigen Tagen habt ihr mit hierbei schon mal geholfen. Jetzt habe ich noch ein Problem.
Der Tabellenblattname (im Beispiel Juli) soll aus der Zelle D4 im Tabellenblatt "wochenplan" entnommen werden.
Kann mir dabei bitte jemand helfen. Was oder wie muss ich was ändern?
Sub KW_Belegung()
Application.ScreenUpdating = False
Sheets("test2").Select
Dim wks_Q As Worksheet 'Tabelle mit dem Themenplan
Dim wks_Z As Worksheet 'Tabelle mit dem KW-Plan
Dim lngKW As Long, lngSpaSo As Long, lngSpaSa As Long, lngZeile As Long, lngSpalte As Long
Dim rngZelle As Range, rngKW As Range
Dim strName As String, varThema As Variant
Set wks_Q = ActiveWorkbook.Worksheets("juli") 'Tabelle mit dem Themenplan
Set wks_Z = ActiveWorkbook.Worksheets("test2") 'Tabelle mit dem KW-Planan
lngKW = wks_Z.Range("B2") 'Eingetragene KW im kalenderplan
With wks_Z
'alte Einträge in KW-Plan ab Zeile 5 löschen
Set rngZelle = .Cells.Find(What:="*", after:=.Range("A1"), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
lngZeile = 1
Else
lngZeile = rngZelle.Row
End If
If lngZeile >= 5 Then
.Range(.Rows(5), .Rows(lngZeile)).ClearContents
End If
End With
With wks_Q
'Spalte So (1. Tag) in der KW im Themenplan suchen
For lngSpalte = 3 To .Cells(3, .Columns.Count).End(xlToLeft).Column
If .Cells(3, lngSpalte).Value = lngKW Then
lngSpaSo = lngSpalte
lngSpaSa = lngSpalte + 6
Exit For
End If
Next
'Namen abarbeiten
For lngZeile = 7 To .Cells(.Rows.Count, 1).End(xlUp).Row
strName = .Cells(lngZeile, 1).Value & ", " & .Cells(lngZeile, 2).Value
'Zellbereich mit den zum Namen eingetragenen Themen
Set rngKW = .Range(.Cells(lngZeile, lngSpaSo), .Cells(lngZeile, lngSpaSa))
With wks_Z
For lngSpalte = 1 To 5 'Themen im KW-Plan durchsuchen
If .Cells(3, lngSpalte) "" Then
varThema = Left(.Cells(3, lngSpalte).Value, 2)
'prüfen ob Thema beim Namen in KW eingetragen
If Application.WorksheetFunction.CountIf(rngKW, varThema) > 0 Then
.Cells(.Rows.Count, lngSpalte).End(xlUp).Offset(1, 0).Value = strName
End If
End If
Next
End With
Next
End With
Application.ScreenUpdating = True
End Sub
Gisela