Spalten suche

Hallo Zusammen,
Ich habe mal wieder ein kleines Problem. Ich habe eine Excel Datei, welche als Arbeitsplaner fungiert. Es gibt für jede Kalenderwoche ein Tabellenblatt. Die Namen stehen untereinander. Rechts neben den Namen sind die Spalten für Montag bis Sonntag.
Im jeweiligen Tag steht immer nur ein Feld, was auch immer für den jeweiligen Dienst gleich bezeichnet ist. Beispiel Spätdienst = Spät, Frühdienst = Früh, Fortbildung = FoBi
Ich würde jetzt gerne eine Übersicht auf einem neuen Tabellenblatt erstellen, wer wie viele Spätdienste frühdienste, Fortbildungen etc gemacht hat.
Wäre das in VbA oder per Formeln einfacher zu lösen?
Es müssen ja auf jeden fall alle Kalenderwochen ausgelesen werden... in der Übersicht ersetzen die Tagezellen dann die Namen der Dienste. Siehe vereinfachte Beispieldatei.
Am liebsten wäre mir es, wenn es ständig aktualisiert wird.
https://www.herber.de/bbs/user/151809.xlsx
Vielen Dank im Voraus!
LG Marco

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Spalten suche

16.03.2022 15:55:20

AW: ... musst Du nicht und ...

16.03.2022 16:41:53

neopa

AW: Spalten suche

16.03.2022 17:56:36

UweD

AW: Spalten suche

17.03.2022 07:47:32

Marco

AW: Spalten suche

17.03.2022 09:25:04

UweD

AW: Spalten suche

17.03.2022 09:43:50

Marco

AW: Spalten suche

17.03.2022 16:08:22

UweD

AW: Spalten suche

17.03.2022 17:05:41

Marco

AW: Spalten suche

18.03.2022 15:38:50

UweD

AW: bitteschön owT

17.03.2022 10:32:21

neopa

AW: Spalten suche

16.03.2022 18:38:29

KlausFz

Sub Zusammenfassung() Dim Tb As Worksheet, LC As Integer, RNG As String, i As Integer Set Tb = Sheets("Übersicht Stunden") RNG = "C3:F50" 'Zielbereich Application.ScreenUpdating = False LC = Tb.Cells(2, Tb.Columns.Count).End(xlToLeft).Column 'letzte Spalte der Zeile 2 With Tb.Range(RNG) 'reset Tempbereich .Offset(0, 5).ClearContents For i = 1 To 53 .Formula2R1C1 = _ "=SUMPRODUCT(('" & i & "'!R3C2:R50C2=RC2)*('" & i & "'!R3C3:R50C9=R2C))+RC[5]" .Offset(0, 5).Value = .Value 'Werte in Tempbereich setzen Next 'aus Temp zurücklesen und löschen .Value = .Offset(0, 5).Value .Offset(0, 5).ClearContents End With MsgBox "Fertig" End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Tb As Worksheet, LC As Integer, RNG As String, i As Integer Set Tb = Sheets("Übersicht ET") RNG = "D4:M70" 'Zielbereich Application.ScreenUpdating = False With Tb.Range(RNG) 'reset Tempbereich .Offset(0, 12).ClearContents For i = 1 To 53 .Formula2R1C1 = _ "=SUMPRODUCT(('" & i & "'!R4C3:R70C3=RC3)*('" & i & "'!R4C4:R70C11=R3C))+RC[12]" .Offset(0, 12).Value = .Value 'Werte in Tempbereich setzen Next 'aus Temp zurücklesen und löschen .Value = .Offset(0, 12).Value .Offset(0, 12).ClearContents End With End Sub

Hallo
es war doch einiges aufwändiger als gedacht.
Den Rest musst du alleine machen
LG UweD
In den Codebereich von "Diese Arbeitsmappe"


Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Workbook_SheetChange"
Dim rngU As String, TbU As Worksheet, rngS As Range, Z, WF
Dim SP As Integer, NName As String, Akt As String, Zeile As Integer, Spalte As Integer
Dim Arr, i As Integer, rTmp As Range, Altwert As String
Set TbU = Sheets("Übersicht")
Set rngS = TbU.Range("D2:O2")
rngU = "D4:J70"
SP = 3 'Spalte mit Name
Set WF = WorksheetFunction
Select Case Sh.Name
Case 1 To 53 'Nur innerhalb dieser Blätter
If Not Intersect(Target, Sh.Range(rngU)) Is Nothing Then 'nur im festgelegten Bereich
For Each Z In Target.Cells
NName = Sh.Cells(Z.Row, SP) ' Name des Mitarbeiters
Akt = Z.Value 'Aktion
If Akt = "" Then
'wenn Aktion entfernt wird
With Application
.EnableEvents = False
.Undo
Altwert = Z.Value
If Altwert  "" Then
Akt = Altwert
Else
Exit Sub
End If
.Undo
.EnableEvents = True
End With
End If
Spalte = WF.CountIf(rngS, Akt) 'ist Aktion vorhanden
If Spalte > 0 Then
Spalte = WF.Match(Akt, rngS, 0)
Zeile = WF.CountIf(TbU.Columns(SP), NName) 'ist Name vorhanden
If Zeile > 0 Then
Zeile = WF.Match(NName, TbU.Columns(SP), 0) 'in welcher Zeile
ReDim Arr(1 To rngS.Columns.Count)
For i = 1 To 53 'alle KWs durchlaufen
If Not IsError(Evaluate(CStr(i) & "!A1")) Then 'Blatt vorhanden?
'alle Tage der Woche durchzählen und in Array merken
Set rTmp = Intersect(Sheets(CStr(i)).Range("D:J"), Sheets(CStr(i)).Rows(Zeile))
Arr(Spalte) = Arr(Spalte) + WF.CountIf(rTmp, Akt)
End If
Next
'zurückschreiben in Zieltabelle
Application.EnableEvents = False
Arr(Spalte) = IIf(Arr(Spalte) = 0, "", Arr(Spalte)) 'Null duch leer ersetzen
rngS.Offset(Zeile - 2, Spalte - 1).Resize(1, 1) = Arr(Spalte)
Application.EnableEvents = True
Else
MsgBox "Fehler: '" & NName & "'  nicht gefunden"
End If
Else
MsgBox Akt & ":  nicht gefunden in " & TbU.Name
End If
Next
End If
End Select
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

https://www.herber.de/bbs/user/151849.xlsm

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread