Public Sub aaa()
If WorksheetFunction.CountIf(Columns("A:A"), Date) > 0 Then
MsgBox "Aktuelles Datum schon vorhanden."
End If
End Sub
Ausgewertet wird das aktive Tabellenblatt. Wenn du ein anderes Blatt auswerten willst, dann musst du noch das entsprechende Blatt vor Columns schreiben (Worksheets("Tabelle3").Columns("A:A")...)Sub DatenInAccessDB()
Range("B22") = Now
Makro4
Dim MsgText As String
Dim db As DAO.Database, rs As DAO.Recordset, SQL As String
On Error GoTo Err_Handler
If WorksheetFunction.CountIf(Worksheets("Tabelle5").Columns("A:A"), Date) = 0 Then
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
While Worksheets("DB_Transfer").Cells(3, 1).Value ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For i = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, i).Value) = _
Worksheets("DB_Transfer").Cells(3, i).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
Wend
db.Close
Else
MsgBox "Datentransfer für den " & Date & " ist schon erfolgt."
End If
End_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
Makro7
Save
End Sub
Wenn du mit Tabelle5 den Codenamen meinst, dann musst du Worksheets("Tabelle5").Columns.... durch Tabelle5.Columns... ersetzen.Private Sub Workbook_BeforeClose(Cancel As Boolean)
If WorksheetFunction.CountIf(Worksheets("ErfassungEinsätze").Columns("C:C"), Date) = 0 Then
Cancel = True
MsgBox "Der Datentransfer für heute wurde noch nicht durchgeführt."
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If WorksheetFunction.CountIf(Worksheets("ErfassungEinsätze").Columns("C:C"), Date) = 0 Then
Cancel = True
MsgBox "Der Datentransfer für heute wurde noch nicht durchgeführt."
End If
End Sub
Ich denke, dass die Prüfung für das Speichern der Datei ja auch erfolgen sollte.Sub DatenInAccessDB()
Range("B22") = Now
Makro4
If WorksheetFunction.CountIf(Worksheets("ErfassungEinstätze").Columns("C:C"), Date) > 0 Then
MsgBox "Aktuelles Datum schon vorhanden."
End If
Dim MsgText As String
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim SQL As String
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
While Worksheets("DB_Transfer").Cells(3, 1).Value ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For I = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, I).Value) = Worksheets("DB_Transfer") _
.Cells(3, I).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
Wend
db.Close
End_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
Makro7
save
End Sub
Sub DatenInAccessDB()
Range("B22") = Now
Makro4
Dim MsgText As String
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim SQL As String
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
While Worksheets("DB_Transfer").Cells(3, 1).Value ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For i = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, i).Value) = Worksheets("DB_Transfer") _
.Cells(3, i).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
Wend
db.Close
End_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
Makro7
save
End Sub