Bereits importierte Dateien ausschliessen
23.10.2018 19:51:50
Patrick
mit Hilfe dieses Forums und seiner User konnte ich es schon realisieren, dass ich per Makro lokale HTML Dateien aus einem bestimmten Verzeichnis in ein Worksheet importieren kann.
Das "Problem" ist jetzt folgendes. Ich möchte nicht, dass jedes Mal beim Ausführen des Makros wieder alle Dateien aus dem Verzeichnis importiert werden. Es sollen nur Dateien importiert werden, die bisher nicht importiert worden sind. Die bisherigen Datensätze sollen erhalten bleiben.
Ist es möglich sich in der Schleife irgendwie den Dateinamen zu "merken" und gegen diesen zu prüfen. Sinngemäß, wenn Dateiname schon vorhanden, mache nichts, ansonsten importiere die Datensätze.
Der VBA-Code sieht bisher wie folgt aus:
'Daten importieren aus HTML Dateien
Sub DatenAusHTML()
Dim browser As Object
Dim url As String
Dim knotenAst As Object
Dim knotenZweig As Object
Dim splitArray() As String
Dim i As Long
Dim zeile As Long
Dim pfad As String
Dim ext As String
Dim datei As String
Dim datum As Date
Dim dateiName As String
pfad = "\\NOR1S300\VK-EL\VK-LOS\02_Tagesgeschaeft\01_Bestandsabgleich\ _
Bestandsabgleich_Daten\"
ext = "*.htm"
datei = Dir(pfad & ext)
zeile = 6
Do While Len(datei) > 0
url = "file:///" & Replace(pfad, "\", "/") & datei
datum = Format(GetFileDate(pfad & datei), "dd.MM.yyyy")
Set browser = CreateObject("internetexplorer.application")
browser.Visible = False
browser.navigate url
Do Until browser.readystate = 4: DoEvents: Loop
Set knotenAst = browser.document.getElementsByTagName("span")
If Not knotenAst Is Nothing Then
For Each knotenZweig In knotenAst
If InStr(1, knotenZweig.innertext, "|") > 0 Then
Cells(zeile, 1).Value = datum
If InStr(datei, "10.htm") > 0 Then
Cells(zeile, 2).Value = "2020/0004"
ElseIf InStr(datei, "11.htm") > 0 Then
Cells(zeile, 2).Value = "2020/0008"
ElseIf InStr(datei, "12.htm") > 0 Then
Cells(zeile, 2).Value = "2020/0009"
ElseIf InStr(datei, "13.htm") > 0 Then
Cells(zeile, 2).Value = "2011/0010"
ElseIf InStr(datei, "14.htm") > 0 Then
Cells(zeile, 2).Value = "2011/0010"
ElseIf InStr(datei, "15.htm") > 0 Then
Cells(zeile, 2).Value = "2010/0008"
ElseIf InStr(datei, "17.htm") > 0 Then
Cells(zeile, 2).Value = "2052/0010"
ElseIf InStr(datei, "17.htm") > 0 Then
Cells(zeile, 2).Value = "2052/0008"
ElseIf InStr(datei, "1.htm") > 0 Then
Cells(zeile, 2).Value = "3772/0010"
ElseIf InStr(datei, "2.htm") > 0 Then
Cells(zeile, 2).Value = "3772/0008"
ElseIf InStr(datei, "3.htm") > 0 Then
Cells(zeile, 2).Value = "3772/0011"
ElseIf InStr(datei, "4.htm") > 0 Then
Cells(zeile, 2).Value = "3772/0015"
ElseIf InStr(datei, "5.htm") > 0 Then
Cells(zeile, 2).Value = "2029/0010"
ElseIf InStr(datei, "6.htm") > 0 Then
Cells(zeile, 2).Value = "2029/0008"
ElseIf InStr(datei, "7.htm") > 0 Then
Cells(zeile, 2).Value = "2020/0010"
ElseIf InStr(datei, "8.htm") > 0 Then
Cells(zeile, 2).Value = "2020/0002"
ElseIf InStr(datei, "9.htm") > 0 Then
Cells(zeile, 2).Value = "2020/0003"
Else:
Cells(zeile, 2).Value = "UNBEKANNT"
End If
splitArray = Split(knotenZweig.innertext, "|")
For i = 0 To UBound(splitArray)
Select Case i
Case 2
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 3).Value = Trim(splitArray(i))
Case 3
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 4).Value = Trim(splitArray(i))
Case 6
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 5).Value = Trim(splitArray(i))
Case 8
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 6).Value = Trim(splitArray(i))
Case 12
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 8).Value = Trim(splitArray(i))
Case 10
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 7).Value = Trim(splitArray(i))
End Select
Next i
zeile = zeile + 1
End If
Next knotenZweig
End If
datei = Dir()
browser.Quit
Set browser = Nothing
Set knotenAst = Nothing
Set knotenZweig = Nothing
Loop
'Spaltenbreite automatisch anpassen
Columns("A:N").EntireColumn.AutoFit
'Absteigend nach Datum sortieren und aufsteigend nach Lager
Worksheets("Bestandsabgleiche").Range("A6").Sort _
Key1:=Worksheets("Bestandsabgleiche").Range("A6"), Order1:=xlDescending, _
Key2:=Worksheets("Bestandsabgleiche").Range("B6"), Order2:=xlAscending, _
Header:=xlYes
'Zeilen löschen für Profilgummi und Plombe aus 2011/0010
lz = Cells(Rows.Count, 1).End(xlUp).Rows.Row
For t = lz To 2 Step -1
If Cells(t, 2).Value = "2011/0010" And (Cells(t, 3).Value = "51103643" Or Cells(t, 3). _
_
Value = "51225670") Then
Rows(t).Delete Shift:=xlUp
End If
Next t
End Sub
'Erstellungsdatum der Dateien ermitteln
Function GetFileDate(ByVal sFilePath As String) As Date
Dim fso As Object
Dim fsFile As Object
Dim dReturn As Date
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(sFilePath) Then
Set fsFile = fso.GetFile(sFilePath)
dReturn = fsFile.DateCreated
Else
dReturn = CDate("01.01.1900")
End If
GetFileDate = dReturn
End Function
Ich habe bewusst einen neuen Beitrag erstellt, da ich denke, dass ansonsten die Übersichtlichkeit verloren geht und so der Fokus auf die Frage direkt ersichtlich ist. Ich hoffe, dass das im Sinne dieses Forums ist.
Für ein paar Tipps wäre ich euch sehr dankbar.
Viele Grüße und einen schönen Abend noch
Patrick