Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1668to1672
1668to1672
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Abfrage Makro

Forumthread: Abfrage Makro

Abfrage Makro
28.01.2019 10:39:33
Alex
Hallo wie müßte ein Makro aussehen dass Prüft ob schon ein Eintrag zu dem heutigen Datum getätigt wurde? Datum befindet sich in Spalte A:A, inklusive einer msg Box die einen Hinweis gibt falls schon ein Eintrag zum heutigen Tag vorhanden ist.
Anzeige

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Abfrage Makro
28.01.2019 10:47:59
Werner
Hallo Alex,
so: 
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")...)
Gruß Werner
Anzeige
AW: Abfrage Makro
28.01.2019 10:52:09
Alex
Danke, reicht ja dann wenn ich den Amkro Namen in meinen aktuellen code mit einbinde oder ? gleich am Anfang.
AW: Abfrage Makro
28.01.2019 11:22:46
Werner
Hallo Alex,
würde mal vermuten so: 
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.
Gruß Werner
Anzeige
AW: Abfrage Makro
28.01.2019 11:26:28
Alex
Danke Werner dein Code klappt super, hab den zu spät gelesen ;) Danke
Gerne u. Danke für die Rückmeldung und...
28.01.2019 11:27:59
Werner
Hallo Alex,
...zukünftig bitte lesen, was neben dem Kästchen steht, in dem du den Haken gesetzt hast.
Der sollte nur dann gesetzt werden, wenn das Problem noch nicht gelöst ist, denn dann wird der Beitrag als offen markiert - und das ist hier ja wohl nicht der Fall.
Gruß Werner
Anzeige
AW: Gerne u. Danke für die Rückmeldung und...
28.01.2019 11:36:02
Alex
Alles klar, ich habe noch eine frage dazu kann man das Makro auch andersrum gestalten dass es abfrägt ob das aktuelle Datum vorhanden ist, wenn es nicht vorhanden ist dann eine msg "Datum noch nicht vorhanden" Quasi bei before workbook.close
AW: Gerne u. Danke für die Rückmeldung und...
28.01.2019 12:13:15
Werner
Hallo Alex,
vielleicht solltest du mal erklären, was du eigentlich vor hast.
Offensichtlich protokollierst du ja das Importdatum in Tabelle5.
Willst du jetzt verhindern, dass die Daten importiert werden wenn das schon erfolgt ist?
Oder willst du die Daten trotzdem importieren und lediglich das Speichern verhindern?
Gruß Werner
Anzeige
AW: Gerne u. Danke für die Rückmeldung und...
28.01.2019 12:52:23
Alex
Zum ersten möchte ich den Import damit stoppen, was ja jetzt passiert.
zum zweiten hätte ich gern wenn das File geschlossen wird eine Art erinnerung kommt falls der erste Schritt noch nicht erfolgt ist. Müßte ja auch mit dem Datum zu regeln sein ? wenn dass Datum von Heute noch nicht in der Liste, msg box "Datenübertragung ist noch offen"
Anzeige
AW: Gerne u. Danke für die Rückmeldung und...
28.01.2019 13:25:54
Werner
Hallo Alex,
der Code gehört ins Codemodul von "DieseArbeitsmappe"
Im VBA-Editor Doppelklick auf "DieseArbeitsmappe" und Code rechts ins Codefenster kopieren. 
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.
Gruß Werner
Anzeige
AW: Gerne u. Danke für die Rückmeldung und...
28.01.2019 13:49:04
Alex
Saubere Arbeit , Danke nochmal. jetzt setz ich auch keinen Haken mher ;)
Danke und viel Spaß noch. o.w.T.
28.01.2019 14:30:53
Werner
AW: Abfrage Makro
28.01.2019 11:23:44
Alex
Hab den Code jetzt mit integriert, Problem wenn er das Datum findet führt er den Transfer trotzdem durch, kann man hier noch sagen dass er das Makro dann abbricht ?
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

Anzeige
AW: Abfrage Makro
28.01.2019 10:48:15
Alex
Das ist mein derzeitiger Code der Daten an eine Access DB sendet, aber um eine doppelte Ausführung zu verhindern wäre eine Abfrage gut mit eben einer msg Box.
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

Anzeige
AW: Abfrage Makro
28.01.2019 10:50:50
Alex
Tabelle5 wäre die wo die Abfrage zu A.A stattfinden sollte
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige