Gewandelte XML in XLS auslesen / Vlookup

Sub Daten()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'clear old data
Range("F6:Q40").ClearContents
Range("F6:F36").Interior.ColorIndex = xlNone
Range("G6:G36").Interior.ThemeColor = xlThemeColorAccent6
Range("G6:G36").Interior.TintAndShade = 0.799981688894314
Range("I6:I36").Interior.ThemeColor = xlThemeColorDark1
Range("I6:I36").Interior.TintAndShade = -4.99893185216834E-02
Range("J6:L36").Interior.Color = 10092543
Range("K6:K36").Interior.Color = 65535
Range("L6:L36").Interior.Color = 10092543
Range("N6:N36").Interior.ThemeColor = xlThemeColorDark1
Range("N6:N36").Interior.TintAndShade = -4.99893185216834E-02
Range("O6:O36").Interior.Color = 10092543
Range("P6:P36").Interior.Color = 65535
Range("Q6:Q36").Interior.Color = 10092543
Application.ScreenUpdating = True
DoEvents
Application.ScreenUpdating = False
If Range("Time")  Date Then
MsgBox "Your chosen timestamp is in the future!"
Exit Sub
End If
If CDate(Day) = Date And Format(Range("secminbid").Value, "hhmmss") > Format(Now, "hhmmss")  _
Then
MsgBox "Your chosen timestamp is in the future!"
Exit Sub
End If
Dim Zeile(4) As Integer
Dim ZelleA As Range
Dim AnzZeile(4) As Integer
Spalte = -1
For File = 1 To 4
Windows(ThisWB).Activate
Time(File) = ActiveWorkbook.Sheets(1).Range("SecMinBid").Offset(0, Spalte).Value         _
_
'timestamp
Dim Filename As String
Filename = Path & Filenames & Format(Day, "yyyymmdd") & "_" & Format(Time(File), " _
hhmmss") & ".xml"
Debug.Print Filename
If Dir(Filename)  "" Then    'check if file exists
NewWB(File) = Filenames & Format(Day, "yyyymmdd") & "_" & Format(Time(File), "  _
_
hhmmss") & ".xml"            'give it a name
Workbooks.OpenXML Filename:=Path & NewWB(File), LoadOption:= _
xlXmlLoadImportToList                  'open it
NewWB(File) = ActiveWorkbook.Name
For Each Zelle In Range("A:A")          'search VHP
If Zelle.Value = VHP Then
Zeile(File) = Zelle.Row         'starting row
count:
If Zelle.Offset(AnzZeile(File), 0).Value = VHP Then   'look if next  _
row is the same VHP
AnzZeile(File) = AnzZeile(File) + 1         'count rows with same   _
_
VHP
GoTo count
End If
GoTo endcount
End If
Next Zelle
endcount:
Else
NewWB(File) = ""  'if not found
End If
Spalte = Spalte + 1
Next File
'now 4 files should be open
'search for max value, which of the files has the most products inside
Max = WorksheetFunction.Max(AnzZeile)
For File = 1 To 4
If Max = AnzZeile(File) Then
Debug.Print NewWB(File)
Windows(NewWB(File)).Activate  'activate the file with the most products
GoTo maxfileopen
End If
Next File
maxfileopen:
Range(Cells(Zeile(File), 7), Cells(Zeile(File) + AnzZeile(File) - 1, 7)).Copy 'copy range of  _
products
Windows(ThisWB).Activate
Range("DeliveryPeriod").Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'search according prices via vlookup
For i = 6 To AnzZeile(File) + 5
On Error Resume Next
'-30sec
Cells(i, 9).FormulaR1C1 = "=VLOOKUP(RC[-2],[" & NewWB(1) & "]Sheet1!R" & Zeile(1) & "C7:R" & _
_
Zeile(1) - 1 + AnzZeile(1) & "C9,2,FALSE)"
Cells(i, 14).FormulaR1C1 = "=VLOOKUP(RC[-7],[" & NewWB(1) & "]Sheet1!R" & Zeile(1) & "C7:R"  _
_
& Zeile(1) - 1 + AnzZeile(1) & "C9,3,FALSE)"
'0sec
Cells(i, 10).FormulaR1C1 = "=VLOOKUP(RC[-3],[" & NewWB(2) & "]Sheet1!R" & Zeile(2) & "C7:R"  _
_
& Zeile(2) - 1 + AnzZeile(2) & "C9,2,FALSE)"
Cells(i, 15).FormulaR1C1 = "=VLOOKUP(RC[-8],[" & NewWB(2) & "]Sheet1!R" & Zeile(2) & "C7:R"  _
_
& Zeile(2) - 1 + AnzZeile(2) & "C9,3,FALSE)"
'+30sec
Cells(i, 11).FormulaR1C1 = "=VLOOKUP(RC[-4],[" & NewWB(3) & "]Sheet1!R" & Zeile(3) & "C7:R"  _
_
& Zeile(3) - 1 + AnzZeile(3) & "C9,2,FALSE)"
Cells(i, 16).FormulaR1C1 = "=VLOOKUP(RC[-9],[" & NewWB(3) & "]Sheet1!R" & Zeile(3) & "C7:R"  _
_
& Zeile(3) - 1 + AnzZeile(3) & "C9,3,FALSE)"
'+60sec
Cells(i, 12).FormulaR1C1 = "=VLOOKUP(RC[-5],[" & NewWB(4) & "]Sheet1!R" & Zeile(4) & "C7:R"  _
_
& Zeile(4) - 1 + AnzZeile(4) & "C9,2,FALSE)"
Cells(i, 17).FormulaR1C1 = "=VLOOKUP(RC[-10],[" & NewWB(4) & "]Sheet1!R" & Zeile(4) & "C7:R" _
_
& Zeile(4) - 1 + AnzZeile(4) & "C9,3,FALSE)"
Next i
Range("G6:Q1048576").Copy
Range("G6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(5, 3).Select
For File = 1 To 4
On Error Resume Next
Windows(NewWB(File)).Close savechanges:=False
Next File
End Sub