Hallo zusammen,

ich habe einen altes Tool inkl. Code von einem ehmaligen Kollegen übernommen, dieser liest Daten einer XML wandelt in XLS und sollte dann entsprechend Preise via Vlookup auslesen und wiedergeben. ( zu verändernder Teil ist bold markiert)

Leider funktioniert die Formel nicht korrekt und es ist auch sehr langwierig zum durchlaufen. Könntet ihr mir hier helfen?

Danke und viele Grüße

Hier der Code

Option Compare Text

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") < 100 Then
    MsgBox ("Wrong time-format!")
    Exit Sub
End If

Dim Path As String
Dim Filenames As String
Dim Day As Date
Dim Time(4) As Date
Dim Sec As Integer
Dim i As Integer
Dim VHP As String
Dim Spalte As Integer
Dim File As Integer

Dim ThisWB As String
Dim NewWB(4) As String

ThisWB = ActiveWorkbook.Name


Path = ActiveWorkbook.Sheets(1).Range("Path").Value
Filenames = ActiveWorkbook.Sheets(1).Range("Name").Value
Day = ActiveWorkbook.Sheets(1).Range("Date").Value
VHP = ActiveWorkbook.Sheets(1).Range("VHP").Value


If CDate(Day) > 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