Fehlerprotokoll
21.01.2019 10:39:02
Okan
Ich hätte folgendes Anliegen.
Ich nutze den folgenden VBA Code um definierte Daten aus definierten Dateien auszulesen. Dabei wird dieser Code mehrmals abgefahren, da mehrere Dateien besichtigt werden sollen.
Sofern der Code einen Error Aufweist, durch z.B. fehlen der Datei, wird ein neues Fenster geöffnet mit dem Text aus dem Teil ErrorHandler.
Ich wollte fragen, ob es möglich ist alle Error auf einem Fenster anzuzeigen, nachdem die letzte Datei geprüft wurde.
Für eure Antworten danke ich im Voraus.
Public Enum SORT_BY
Sort_by_None
Sort_by_Name
Sort_by_Path
Sort_by_Size
Sort_by_Last_Access
Sort_by_Last_Modyfy
Sort_by_Date_Create
End Enum
Public Enum SORT_ORDER
Sort_Order_Ascending
Sort_Order_Descending
End Enum
Public Type FILEINFO
FI_FileName As String
FI_FullName As String
FI_FolderPath As String
FI_FileSize As Long
FI_LastAccess As Date
FI_LastModify As Date
FI_DateCreate As Date
End Type
Public Sub Import_Data(wks As Worksheet)
On Error GoTo ErrorHandler
Dim objFileSearch As clsFileSearch
Dim lngIndex As Long, lngCount As Long
Dim varOutput As Variant
Dim strPath As String, strFormula As String
Const cstrTabname As String = "Report" 'Tabellenname
With wks
If .Range("C7") = "" Or .Range("C8") = "" Then
MsgBox ("Bitte Cellen C7 & C8 mit Daten füllen.")
Else
strPath = _
"I:\TS_Dokument\Partikelfallenanalyse\Analyse\" & .Cells(7, 3).Value & "\" & .Cells(8, _
_
_
_
_
_
_
3).Value & "\" ' _
Startverzeichnis
If Right(strPath, 1) "\" Then strPath = strPath & "\"
.Range("B17:K36").ClearContents
Set objFileSearch = New clsFileSearch
With objFileSearch
.NewSearch = True
.CaseSenstiv = False
.Extension = "*.xlsx*"
.FolderPath = strPath
.SearchLike = "*Partikelfallenanalyse_" & wks.Cells(7, 3).Value & "_" & wks.Name & "_*"
.SubFolders = False
If .Execute(Sort_by_Name, Sort_Order_Descending) > 0 Then
ReDim varOutput(1 To 20, 1 To 10)
lngCount = 1
For lngIndex = 1 To .FileCount
If lngCount > 20 Then Exit For
strFormula = "='" & .Files(lngIndex).FI_FolderPath
strFormula = strFormula & "[" & .Files(lngIndex).FI_FileName & "]"
strFormula = strFormula & cstrTabname & "'!"
varOutput(lngCount, 1) = strFormula & "U48"
varOutput(lngCount, 2) = strFormula & "I17"
varOutput(lngCount, 3) = strFormula & "I18"
varOutput(lngCount, 4) = strFormula & "I19"
varOutput(lngCount, 5) = strFormula & "I20"
varOutput(lngCount, 6) = strFormula & "I21"
varOutput(lngCount, 7) = strFormula & "I22"
varOutput(lngCount, 8) = strFormula & "I23"
varOutput(lngCount, 9) = strFormula & "I24"
varOutput(lngCount, 10) = strFormula & "U44"
lngCount = lngCount + 1
Next
End If
End With
With .Range("B17").Resize(UBound(varOutput, 1), 10)
.Formula = varOutput
.Value = .Value
End With
Set objFileSearch = Nothing
End If
End With
Exit Sub
ErrorHandler:
MsgBox "Es wurde ein Fehler" & vbCr & "in Abteilung: " & wks.Cells(7, 3).Value & vbCr & "in _
Station: " & wks.Name & vbCr & " gefunden." & vbCr & vbCr & "Bitte überprüfen Sie für den _
aktuellen Fehler im Windows Explorer:" & vbCr & "den Pfad des Speicherortes" & vbCr & "die _
Ordnerbezeichnungen" & vbCr & "die Dateinamen" & vbCr & vbCr & "Bitte überprüfen Sie für den _
aktuellen Fehler in dieser Excel-Arbeitsmappe:" & vbCr & "die Sheetsbezeichnung (auch im VBA)" & _
_
_
vbCr & "den Inhalt der Zellen C7 & C8 im aktuellen Fehlersheet" & vbCr & vbCr & "Wichtiger _
Hinweis: Es können nach beheben des aktuellen Fehlers weitere Fehlermeldungen für die _
nachfolgenden Sheets auftreten." & vbCr & vbCr & vbCr & "Sollten Sie den Fehler nicht beheben können oder haben Fragen zu dem Problem kontaktieren Sie bitte Okan Firat. Danke."
End Sub
VG