Datumsabgleich zwischen Quell- und Zieldatei
Dietmar
vor längerer Zeit habe ich von Sepp einen VBA-Code zum Datenübertrag in ein auszuwählendes Sheet erhalten.
Diesen möchte ich nun gerne wie folgt weiterentwickeln:
Alle gegeneinander zu prüfenden Zellen enthalten ein Datum.
Zwischen der Quelldatei (dort im Tabellenblatt 'Fixdaten', Range("E5")) und der Zieldatei (die nur aus einemTabellenblatt besteht) dort in den Zellen C5 und F5 soll eine Datumsüberprüfung stattfinden, die den Fortgang des Codes stoppt oder weiter zulässt. Näheres siehe auskommentierter Text an der entsprechenden Stelle im Code.
Ich trau mich da nicht ran, weil ich den Code nicht vermasseln will. Er läuft nämlich super gut durch
Vielen Dank für jede Hilfe!
Viele Grüße
Dietmar aus Aachen
Hier nun der Code mit Erläuterungen an der entsprechenden Stelle:
Option Explicit
Sub DatenUebertrag()
Dim strFile As String, strNewName As String
Dim objWB As Workbook, objWS As Worksheet, objTarget As Worksheet
Dim rng As Range, rngF As Range, rngC As Range
Dim blnOpen As Boolean
Dim lngRow As Long, lngLast As Long, lngN As Long
Dim varResult As Variant
On Error GoTo ErrExit
GMS
ChDrive "C"
ChDir "C:\Testordner\01_Testunterordner"
strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm")
If strFile = "Falsch" Or strFile = ThisWorkbook.FullName Then GoTo ErrExit
blnOpen = IsOpen(strFile)
If blnOpen Then
Set objWB = Workbooks(Mid(strFile, InStrRev(strFile, "\") + 1))
Else
Set objWB = Workbooks.Open(strFile)
End If
Set objTarget = objWB.Sheets(1)
For Each objWS In ThisWorkbook.Worksheets
With objWS
Select Case .Name
'>>>>>>>> hier soll nun die Prüfung folgen >>>>>
'In der Quelldatei steht im Tabellenblatt Fixdaten.Range(E4) ein beliebiges Datum
'Die auszuwählende Zieldatei besteht nur aus einem Tabellenblatt.
'In Zieldatei.Range(D5) steht ein festgelegtes Datum und
'in Zieldatei.Range(F5) steht ein festgelegtes Datum (erster und letzter Tag einer Woche)
'VOR der Ausführung der nachfolgenden Befehle soll geprüft werden:
'Wenn das Datum in Quelldatei.Range(E4) kleiner ist als das Datum in Zieldatei.Range(D5)
'ODER größer ist als das Datum in 'Zieldatei.Range(F5), dann soll ein Hinweisfenster _
erscheinen und darauf 'hinweisen. 'Mit JA oder NEIN soll die 'Möglichkeit gegeben werden abzubrechen oder weiterzumachen.
' "" Then
varResult = Application.Match(rngC.Offset(0, -1), rngF, 0)
If IsNumeric(varResult) Then
objTarget.Cells(varResult + 4, 2) = rngC.Value
End If
End If
Next
'(
) weitere Übertragungsbefehle entfernt für Nachfrage bei Herber.de
ErrExit:
With Err
If .Number = 1004 And .Description Like "*schreibgeschützt*" Then
.Clear
Resume Next
End If
If .Number 0 Then MsgBox .Number & vbLf & vbLf & .Description, vbExclamation, "Fehler"
End With
GMS True
Set objWB = Nothing
Set objWS = Nothing
Set rng = Nothing
Set rngF = Nothing
Set rngC = Nothing
End Sub
Private Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Private Function IsOpen(ByVal WBFullName As String) As Boolean
Dim objWB As Workbook
For Each objWB In Application.Workbooks
If objWB.FullName = WBFullName Then
IsOpen = True
Exit For
End If
Next
End Function