VBA auswahlbox für Wochentage

Hallo,
ich komme bei folgendem Problem nicht weiter. Ich hoffe ihr könnt mir helfen.
Ich habe mal ein Beispiel aus meiner Datei in eine Neue kopiert um es nicht zu Umfangreich zu zeigen. Ich habe hier eine Liste mit Mitarbeitern wo ich für jeden MA die Stundenzahl pro Woche habe. Ganz vorne in der Liste stehen die Arbeitstage der MA und die Stundenzahl pro Tag.
Da meine Originaldatei sehr groß ist habe ich mir oben links eine Schaltfläche erstellt mit der ich einen neuen Mitarbeiter eintragen kann. Ich habe mir ein Makro erstellt um dann den Namen die Funktion und die Kurzform einzutragen, jetzt möchte ich aber auch noch angeben können an welchen tagen in der Woche der MA arbeitet. So das ich auswähle MO, Di, DO, Fr, Sa und das System dann automatisch bei diesen Tagen eine 7,5 einträgt. Gibt es die Möglichkeit eine Checkbox anzeigen zu lassen in der ich nur an den Tagen die ich möchte ein häckchen machen kann?
Dazu dann auch gleich die Frage zu der Funktion der MA, ich habe für die verschiedenen Funktionen Farben hinterlegt. Kann ich über VBA automatisch gleich die richtige Farbe der Zelle zuweisen lassen?
hier mal der Link zu der Datei
https://dl.dropboxusercontent.com/u/86380884/beispiel_neu.xlsm
Danke und Gruß
Ben

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub UserForm_Terminate() Dim iColLast As Long With Sheets(sWksAnwesenheit) iColLast = .Cells(1, Columns.Count).End(xlToLeft).Column With .Range(.Cells(iRow, 13), .Cells(iRow, iColLast)) .FormulaR1C1 = "=IF(RC[-7]="""","""",RC[-7])" .Value = .Value End With End With End Sub

Private Sub UserForm_Terminate() Dim iColLast As Long Dim iColFirst As Long With Sheets(sWksAnwesenheit) iColLast = .Cells(1, Columns.Count).End(xlToLeft).Column 'ich bekomme das "worksheetfunction.match" mit Datum nie hin! 'darum der geschummelte Umweg über eine Zelle. With .Cells(iRow, 12) .FormulaR1C1 = "=MATCH(TODAY(),R1,)" On Error GoTo errHnd iColFirst = .Value On Error GoTo 0 .ClearContents End With With .Range(.Cells(iRow, iColFirst), .Cells(iRow, iColLast)) .FormulaR1C1 = "=IF(INDEX(C1:C11,ROW(),MATCH(R2C,R2,))=0,"""",INDEX(C1:C11,ROW(),MATCH( _ R2C,R2,)))" .Value = .Value End With End With Exit Sub errHnd: MsgBox ("In dieser Tabelle gibt es kein Heute!") End Sub

Workbooks.Open Filename:= _ "Z:\Einteilung.xlsx" Dim i As Integer For i = 1 To Worksheets.Count If Worksheets(i).Name = Date Then Worksheets(i).Activate Range("A1").Select Windows("anwesenheit_2013.xlsm").Activate Range("A1:M42").Select Selection.Copy Windows("Einteilung.xlsx").Activate Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveSheet.Paste Range("A1:B2").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = Date ActiveWorkbook.Save ActiveWindow.Close Range("O13").Select

Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = Date Windows("anwesenheit_2013.xlsm").Activate Range("A1:M42").Select Selection.Copy Windows("Einteilung.xlsx").Activate Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveSheet.Paste Range("A1:B2").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = Date ActiveWorkbook.Save ActiveWindow.Close Range("O13").Select

Sub DateiDingens() Dim wkbOld As Workbook Dim wkbNew As Workbook Set wkbOld = ActiveWorkbook 'Kopieren aus dem Mastersheet Sheets(Format(Date, "TT.MM.YYYY")).Range("A1:M42").Copy 'Anderes Sheet öffnen If Not WkbExists("Z:\Einteilung.xlsx") Then MsgBox ("Die Datei Einteilung wurde nicht gefunden!") Exit Sub End If Call FileCheckOpen("Z:", "Einteilung.xlsx") Set wkbNew = ActiveWorkbook 'Das "heute"-Blatt erstellen oder aktivieren If Not WksSheetExists(Format(Date, "TT.MM.YYYY")) Then Sheets.Add After:=Sheets(Sheets.Count) Else Sheets(Format(Date, "TT.MM.YYYY")).Activate End If 'Die Inhalte aus dem alten Sheet einfügen With ActiveSheet .Range("A1").PasteSpecial .Range("A1").FormulaR1C1 = Date End With 'speichern, schließen, zurück zum alten Sheet wkbNew.Save wkbNew.Close wkbOld.Activate End Sub '*********************************************************************************************** _ '* Module to open needed files. Checks if Files are open or not. '* If file is already open, do nothing - else open it '* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm '* modified by Klaus Meyer von der Twer / 16.NOV.2012 '*********************************************************************************************** _ 'Example: 'Call FileCheckOpen("C:\TMP", "Filename.xls") 'path and filename can be RANGE from excelsheet Sub FileCheckOpen(sPath As String, sFile As String) sPath = sPath & "/" & sFile If WkbExists(sFile) = False Then If Dir(sPath) = "" Then MsgBox "File " & sPath & " not found!" Else Workbooks.Open sPath, UpdateLinks:=False End If Else Workbooks(sFile).Activate End If End Sub Function WkbExists(sFile As String) As Boolean Dim wkb As Object On Error Resume Next Set wkb = Workbooks(sFile) If Not wkb Is Nothing Then WkbExists = True End If On Error GoTo 0 End Function Function WksSheetExists(sSheet As String) As Boolean Dim wks As Object On Error Resume Next Set wks = Sheets(sSheet) If Not wks Is Nothing Then WksSheetExists = True End If On Error GoTo 0 End Function

Sub sync_visual() Dim wkbOld As Workbook Dim wkbNew As Workbook Set wkbOld = ActiveWorkbook 'Kopieren aus dem Mastersheet Sheets("MA Einteilung").Range("A1:M42").Copy 'Anderes Sheet öffnen If Not WkbExists("D:\Single Medium spät\Einteilung.xlsx") Then MsgBox ("Die Datei Einteilung wurde nicht gefunden!") Exit Sub End If Call FileCheckOpen("D:\Single Medium spät\", "Einteilung.xlsx") Set wkbNew = ActiveWorkbook 'Das "heute"-Blatt erstellen oder aktivieren If Not WksSheetExists(Format(Date, "TT.MM.YYYY")) Then Sheets.Add After:=Sheets(Sheets.Count) Else Sheets(Format(Date, "TT.MM.YYYY")).Activate End If 'Die Inhalte aus dem alten Sheet einfügen With ActiveSheet .Range("A1").PasteSpecial .Range("A1").FormulaR1C1 = Date End With 'speichern, schließen, zurück zum alten Sheet wkbNew.Save wkbNew.Close wkbOld.Activate Application.ScreenUpdating = True End Sub

'Das "heute"-Blatt erstellen oder aktivieren If Not WksSheetExists(Format(Date, "TT.MM.YYYY")) Then Sheets.Add After:=Sheets(Sheets.Count) activesheet.name = Format(Date, "TT.MM.YYYY") Else Sheets(Format(Date, "TT.MM.YYYY")).Activate End If

'Anderes Sheet öffnen0 If Not WkbExists("D:\Single Medium spät\Einteilung.xlsx") Then HIER MsgBox ("Die Datei Einteilung wurde nicht gefunden!") Exit Sub End If ODER HIER? Call FileCheckOpen("D:\Single Medium spät", "Einteilung.xlsx") Set wkbNew = ActiveWorkbook

Hallo Ben,
korrigierter Code anbei. Im Endeffekt muss nur die Reihenfolge "Workbook öffnen / Workbook überprüfen" getauscht werden (Rudis Einwand):

'Anderes Sheet öffnen
Call FileCheckOpen("D:\Single Medium spät", "Einteilung.xlsx")
If Not WkbExists("D:\Single Medium spät\Einteilung.xlsx") Then
'Meldung auskommentiert, erscheing bereits in FileCheckOpen
'MsgBox ("Die Datei Einteilung wurde nicht gefunden!")
Exit Sub
End If

Aber um weitere Mißverständnisse zu vermeiden, poste ich hier nochmal den gesamten Code mit allen besprochenen Änderungen:

Sub DateiDingens()
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Set wkbOld = ActiveWorkbook
'Kopieren aus dem Mastersheet
Sheets(Format(Date, "TT.MM.YYYY")).Range("A1:M42").Copy
'Anderes Sheet öffnen
Call FileCheckOpen("D:\Single Medium spät", "Einteilung.xlsx")
If Not WkbExists("D:\Single Medium spät\Einteilung.xlsx") Then
'Meldung auskommentiert, erscheing bereits in FileCheckOpen
'MsgBox ("Die Datei Einteilung wurde nicht gefunden!")
Exit Sub
End If
Set wkbNew = ActiveWorkbook
'Das "heute"-Blatt erstellen oder aktivieren
If Not WksSheetExists(Format(Date, "TT.MM.YYYY")) Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Format(Date, "TT.MM.YYYY")
Else
Sheets(Format(Date, "TT.MM.YYYY")).Activate
End If
'Die Inhalte aus dem alten Sheet einfügen
With ActiveSheet
.Range("A1").PasteSpecial
.Range("A1").FormulaR1C1 = Date
End With
'speichern, schließen, zurück zum alten Sheet
wkbNew.Save
wkbNew.Close
wkbOld.Activate
End Sub
'*********************************************************************************************** _
_
'* Module to open needed files. Checks if Files are open or not.
'* If file is already open, do nothing - else open it
'* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm
'* modified by Klaus Meyer von der Twer / 16.NOV.2012
'*********************************************************************************************** _
_
'Example:
'Call FileCheckOpen("C:\TMP", "Filename.xls")
'path and filename can be RANGE from excelsheet
Sub FileCheckOpen(sPath As String, sFile As String)
sPath = sPath & "/" & sFile
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sFile).Activate
End If
End Sub
Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function
Function WksSheetExists(sSheet As String) As Boolean
Dim wks As Object
On Error Resume Next
Set wks = Sheets(sSheet)
If Not wks Is Nothing Then
WksSheetExists = True
End If
On Error GoTo 0
End Function

Grüße,
Klaus M.vdT.

Beliebteste Forumthreads (12 Monate)

42
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA auswahlbox für Wochentage

42 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

42
Beiträge zum Forumthread

Beiträge zu diesem Forumthread