Public Sub aaa()
If WorksheetFunction.CountIf(Columns("A:A"), Date) > 0 Then
MsgBox "Aktuelles Datum schon vorhanden."
End If
End Sub
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
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
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