AW: Mist! schon wieder der falsche Code ;-))
27.11.2018 18:04:25
Sepp
Hallo Christoph,
ich schrieb: "Außerdem gehe ich davon aus, das in C1 ein 'echtes' Datum steht."
Deine Antwort:"In C1 steht ein echtes Datum, allerdings im Benutzerdefinierten Format von TTMMJJ."
In C1 steht aber die Zahl 271118, das ist kein Datum! Die Zelle ist als Standard formatiert, als Datum würde dort der 17.04.2642 stehen! Als Datum mit 'MMTTJJ' formatiert würde dort 43431 stehen und 271118 angezeigt.
Hier der angepasste Code für deine Zahl die du als Datum interpretierst.
Modul Modul1
Option Explicit
Sub collectData()
Dim strFile As String
Dim varRet As Variant, varDate As Variant, varValue As Variant, varData As Variant
Dim lngRow As Long, lngCol As Long, dblOldTime As Double, dblNewTime As Double
Const FILEPATH As String = "D:\Forum\Test\" 'Ordner der Quelldateien mit abschließendem Backslash!
Const SHEETNAME As String = "Anwesenheitsliste" 'Tabellenname in der Quelldatei.
Const DATECELL As String = "C1" 'Zelle mit dem Datum.
Const VALUECELL As String = "O4" 'Zelle mit dem Wert.
With Sheets("NoShow Zähler")
varData = .Range("B4:X34")
strFile = Dir(FILEPATH & "*.xls*", vbNormal)
Do While strFile <> ""
dblNewTime = CDbl(FileDateTime(FILEPATH & strFile))
dblOldTime = dblNewTime
With Sheets("Update")
varRet = Application.Match(strFile, .Columns(1), 0)
If IsNumeric(varRet) Then dblOldTime = .Cells(varRet, 2)
End With
If IsError(varRet) Or dblNewTime > dblOldTime Then
varDate = GetValue(FILEPATH, strFile, SHEETNAME, DATECELL)
varValue = GetValue(FILEPATH, strFile, SHEETNAME, VALUECELL)
If IsNumeric(varDate) Then
varDate = DateSerial(Right(varDate, 2), Mid(varDate, 3, 2), Left(varDate, 2))
If Year(varData(1, 1)) = Year(varDate) Then
lngCol = Month(varDate) * 2
lngRow = Day(varDate)
varData(lngRow, lngCol) = varValue
With Sheets("Update")
If IsNumeric(varRet) Then
.Cells(varRet, 2) = dblNewTime
Else
With .Cells(.Rows.Count, 1).End(xlUp)
.Offset(1, 0) = strFile
.Offset(1, 1) = dblNewTime
End With
End If
End With
End If
End If
End If
strFile = Dir
Loop
.Range("B4:X34") = varData
End With
End Sub
Private Function GetValue(ByVal vFilePath As String, ByVal vFileName As String, ByVal vSheetName As String, ByVal _
vTargetAddress As String) As Variant
Dim Argument As String
On Error GoTo ErrorHandler
If Right(vFilePath, 1) <> "\" Then vFilePath = vFilePath & "\"
Argument = "'" & vFilePath & "[" & vFileName & "]" & vSheetName & "'!" & _
Range(vTargetAddress).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(Argument)
Exit Function
ErrorHandler:
GetValue = CVErr(xlErrRef)
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0