Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Gewandelte XML in XLS auslesen / Vlookup

Betrifft: Gewandelte XML in XLS auslesen / Vlookup von: Sandra
Geschrieben am: 12.08.2014 13:54:36

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 schonmal und viele Grüße

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

Und hier die Dateien


  

Betrifft: AW: Gewandelte XML in XLS auslesen / Vlookup von: fcs
Geschrieben am: 12.08.2014 16:15:01

Hallo Sandra,

es ist etwas mühsehlig, sich durch dein Makro zu wühlen.

Folgende Sachen kann man machen, um Formelfehler zu vermeiden und das Ganze in der Ausführung zu beschleunigen:
1. In die SVERWEIS-Formeln zusätzliche Hochkommata ' einbauen, so das Dateinamen/Blattnamaen mit Leer- und Sonderzeichen keinen Kummer machen.

2. SVERWEIS-Formeln nicht Zellen sondern spaltenweise einfügen

3. Den Berechnungsmodus vor dem Einfügen der Formeln auf Manuell setzen und danach wieder auf automatisch.

4. Beim Ersetzen der Formeln durch die Werte den zu kopierenden Bereich auf den tatsächlichen Zellbereich begrenzen und nicht bis zur millionsten Zeile kopieren

Außerdem sollten die Variablen-Deklarationen möglichs alle am Beginn des Makros stehen, und es sollten alle Variablen deklariert sein. Dies hat weniger mit der Funktion des Makros zu tun als mit Programmierstil.

Gruß
Franz

Sub Daten()
    
    Dim Zelle As Range, Max As Long
    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 Zeile(4) As Integer
    Dim ZelleA As Range
    Dim AnzZeile(4) As Integer
    
    Dim ThisWB As String
    Dim NewWB(4) As String
    
    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
    

    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
    

    



    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
            'give it a name
            NewWB(File) = _
                Filenames & Format(Day, "yyyymmdd") & "_" & Format(Time(File), "hhmmss") & ". _
xml"
            'open it
            Workbooks.OpenXML Filename:=Path & NewWB(File), LoadOption:=xlXmlLoadImportToList
                
            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
    Application.Calculation = xlCalculationManual
'    For i = 6 To AnzZeile(File) + 5
       On Error Resume Next
      '-30sec
       If NewWB(1) <> "" Then
          Range(Cells(6, 9), Cells(AnzZeile(File) + 5, 9)).FormulaR1C1 = _
            "=VLOOKUP(RC[-2],'[" & NewWB(1) & "]Sheet1'!R" & Zeile(1) _
            & "C7:R" & Zeile(1) - 1 + AnzZeile(1) & "C9,2,FALSE)"
         
          Range(Cells(6, 14), Cells(AnzZeile(File) + 5, 14)).FormulaR1C1 = _
            "=VLOOKUP(RC[-7],'[" & NewWB(1) & "]Sheet1'!R" & Zeile(1) _
            & "C7:R" & Zeile(1) - 1 + AnzZeile(1) & "C9,3,FALSE)"
       End If
      '0sec
       If NewWB(2) <> "" Then
          Range(Cells(6, 10), Cells(AnzZeile(File) + 5, 10)).FormulaR1C1 = _
            "=VLOOKUP(RC[-3],'[" & NewWB(2) & "]Sheet1'!R" & Zeile(2) _
            & "C7:R" & Zeile(2) - 1 + AnzZeile(2) & "C9,2,FALSE)"
         
          Range(Cells(6, 15), Cells(AnzZeile(File) + 5, 15)).FormulaR1C1 = _
            "=VLOOKUP(RC[-8],'[" & NewWB(2) & "]Sheet1'!R" & Zeile(2) _
            & "C7:R" & Zeile(2) - 1 + AnzZeile(2) & "C9,3,FALSE)"
       End If
      
      '+30sec
       If NewWB(3) <> "" Then
          Range(Cells(6, 11), Cells(AnzZeile(File) + 5, 11)).FormulaR1C1 = _
            "=VLOOKUP(RC[-4],'[" & NewWB(3) & "]Sheet1'!R" & Zeile(3) _
            & "C7:R" & Zeile(3) - 1 + AnzZeile(3) & "C9,2,FALSE)"
           
          Range(Cells(6, 16), Cells(AnzZeile(File) + 5, 16)).FormulaR1C1 = _
            "=VLOOKUP(RC[-9],'[" & NewWB(3) & "]Sheet1'!R" & Zeile(3) _
            & "C7:R" & Zeile(3) - 1 + AnzZeile(3) & "C9,3,FALSE)"
       End If
      
      '+60sec
       If NewWB(4) <> "" Then
          Range(Cells(6, 12), Cells(AnzZeile(File) + 5, 12)).FormulaR1C1 = _
            "=VLOOKUP(RC[-5],'[" & NewWB(4) & "]Sheet1'!R" & Zeile(4) _
            & "C7:R" & Zeile(4) - 1 + AnzZeile(4) & "C9,2,FALSE)"
           
          Range(Cells(6, 17), Cells(AnzZeile(File) + 5, 17)).FormulaR1C1 = _
            "=VLOOKUP(RC[-10],'[" & NewWB(4) & "]Sheet1'!R" & Zeile(4) _
            & "C7:R" & Zeile(4) - 1 + AnzZeile(4) & "C9,3,FALSE)"
       End If
'    Next i
    ActiveSheet.Calculate
    Application.Calculation = xlCalculationAutomatic
    Max = AnzZeile(File) + 5
    Range("G6:Q" & Max).Copy   '1048576- letzte Zeile auf sinnvolle Zahl reduzieren oder genau  _
berechnen
    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
      If NewWB(4) <> "" Then
          Windows(NewWB(File)).Close savechanges:=False
      End If
    Next File
  
    Application.ScreenUpdating = True

End Sub



 

Beiträge aus den Excel-Beispielen zum Thema "Gewandelte XML in XLS auslesen / Vlookup"