Xml per Makro Importieren funktioniert nur bei bestimmten Excel

Hallo,

ich möchte ein xml per folgendem Code ins Excel einlesen.

Bei Zeile 25 ist aber aufgrund folgendem Fehler Schluss: Laufzeitfehler 5 - Ungültiger Prozeduraufruf oder ungültiges Argument

Das Interessante:

Das Makro wurde auf einem Excel 2010 32-bit programmiert. Da funktioniert es!
Bei meinem Excel 2013 32-bit geht es nicht.

Die Verweise im VBA-Editor sind die Gleichen.

Könnt ihr mir bitte sagen, was hier falsch läuft?
Und wie man den Code einfacher bzw. gleich kompatibler gestalten könnte?

LG

VBA:

Sub xml_einlesen_Click()
   Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
    Application.FileDialog(msoFileDialogOpen).Filters.Clear
    Call Application.FileDialog(msoFileDialogOpen).Filters.Add("XML-Dateien", "*.xml")  
    Application.FileDialog(msoFileDialogOpen).InitialFileName = ThisWorkbook.Path
    Dim intchoice As Integer
    intchoice = Application.FileDialog(msoFileDialogOpen).Show
    If intchoice = 0 Then
        Exit Sub
    End If
    Dim Path As String
    Path = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
    Dim oWB As Workbook
    Set oWB = ThisWorkbook
    Dim originsheet As Worksheet
    Set originsheet = oWB.ActiveSheet
    Dim oWB2 As Excel.Workbook
    Set oWB2 = Excel.Workbooks.Add()
    Dim oSheet As Worksheet
    Set oSheet = oWB2.ActiveSheet
    Dim oSheet2 As Worksheet
    Set oSheet2 = oWB2.Sheets(2)
    oSheet2.Activate
    oWB2.XmlImport URL:=Path, ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$A$1")  
    Cells.Select
    Selection.Copy
    Sheets("Tabelle1").Select  
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    
    Columns("A:C").Select  
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Rows("2:4").Select  
    Selection.Delete Shift:=xlUp
    Dim i As Integer
    i = 1
    Do Until Range("C" & CStr(i)).Text = ""  
        i = i + 1
    Loop
    Range("D2").Select  
    ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-1],"" "" & RC[-2],"""")"  
    Range("D2").Select  
    Selection.AutoFill Destination:=Range("D2:D" & CStr(i)), Type:=xlFillDefault  
   
    Range("D2:D" & CStr(i)).Select  
    Selection.Copy
    Range("F2").Select  
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Range("F2").Select  
    Application.CutCopyMode = False
    Dim j As Integer
    j = 2
    Do Until j = i
        Range("F" & CStr(j)).Select  
        ActiveCell.FormulaR1C1 = "=" & ActiveCell.Text  
        j = j + 1
    Loop
    Cells.Select
    Selection.Copy
    oWB.Activate
    originsheet.Activate

    Range("A1").Select  
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Range("A1").Select  
    Columns("A:A").EntireColumn.AutoFit  
    Columns("C:C").EntireColumn.AutoFit  
    Columns("D:D").EntireColumn.AutoFit  
    Application.DisplayAlerts = False
    'oWB.save  
    oWB2.Close (False)
    
    Application.DisplayAlerts = True
    
End Sub

xml-Code:

<?xml version="1.0" encoding="utf-8"?>  
<ParamWithValueList xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">  
  <version>20080502</version>
  <parameterTypes>
    <ParamType>
      <typeName>Inventor</typeName>
      <typeCode>0</typeCode>
    </ParamType>
    <ParamType>
      <typeName>String</typeName>
      <typeCode>1</typeCode>
    </ParamType>
    <ParamType>
      <typeName>Boolean</typeName>
      <typeCode>2</typeCode>
    </ParamType>
  </parameterTypes>
  <parameters>
    <ParamWithValue>
      <name>Ring_Nutbreite</name>
      <typeCode>mm</typeCode>
      <value>2 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Aussendia</name>
      <typeCode>mm</typeCode>
      <value>83 mm + 5 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Ring_Innendia</name>
      <typeCode>mm</typeCode>
      <value>70 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Schaftdia</name>
      <typeCode>mm</typeCode>
      <value>60 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Stufenhoehe</name>
      <typeCode>mm</typeCode>
      <value>15 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Schafthoehe</name>
      <typeCode>mm</typeCode>
      <value>35 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Ring_Nuttiefe</name>
      <typeCode>mm</typeCode>
      <value>2 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>sa_0</name>
      <typeCode>MPa</typeCode>
      <value>10 MPa</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>d8</name>
      <typeCode>mm</typeCode>
      <value>60 mm + 6.4 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>d9</name>
      <typeCode>mm</typeCode>
      <value>Ring_Nuttiefe</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>d10</name>
      <typeCode>mm</typeCode>
      <value>74.000 mm</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>sa_1</name>
      <typeCode>N</typeCode>
      <value>0.000 N</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>sa_2</name>
      <typeCode>N</typeCode>
      <value>0.000 N</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>sa_3</name>
      <typeCode>N</typeCode>
      <value>-1500000 N</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Test</name>
      <typeCode>mm</typeCode>
      <value>Schafthoehe + Ring_Nuttiefe</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
    <ParamWithValue>
      <name>Winkel</name>
      <typeCode>grd</typeCode>
      <value>45 grd</value>
      <comment />
      <isKey>false</isKey>
    </ParamWithValue>
  </parameters>
</ParamWithValueList>

Please also mark the comments that contributed to the solution of the article

Content-Key: 356209

Url: https://administrator.de/contentid/356209

Printed on: April 27, 2024 at 15:04 o'clock

6 Comments

Latest comment

Da ist jede Menge unnötiger Müll drin, vor allem das manuelle Select & Co. ist volkommen überflüssig ... das macht das ganze doch nur unnötig langsam.

Besser umgeschrieben etwa so:

Sub xml_einlesen_Click()
    Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "XML-Dateien", "*.xml"  
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then
            Path = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Set sheetorigin = ActiveSheet
    
    With Workbooks.Add()
        .XmlImport URL:=Path, ImportMap:=Nothing, Overwrite:=True, Destination:=Sheets(1).Range("$A$1")  
        With .Sheets(1)
            .Columns("A:C").Delete Shift:=xlToLeft  
            .Rows("2:4").Delete Shift:=xlUp  
            Set newInc = .Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)  
            .Range("D2").FormulaR1C1 = "=SUBSTITUTE(RC[-1],"" "" & RC[-2],"""")"  
            .Range("D2").AutoFill Destination:=.Range("D2:D" & newInc.Row), Type:=xlFillDefault  
            .Range("D2:D" & newInc.Row).Copy  
            .Range("F2").PasteSpecial Paste:=xlPasteValues  
            For Each cell In .Range("F2:F" & newInc.Row)  
                cell.FormulaR1C1 = cell.Text
            Next
            .UsedRange.Copy
            With sheetorigin
                .Range("A1").PasteSpecial Paste:=xlPasteValues  
                .Range("A:A,C:C,D:D").EntireColumn.AutoFit  
            End With
        End With
        .Close False
    End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
End Sub

Hello,

da gibt er mir leider bei Zeile 18 des Codes einen Laufzeitfehler 438 - "Objekt unterstützt diese Eigenschaft oder Methode nicht".

Wüsstest du an was das liegen kann?

LG

Da war eine Zeile an die falsche Stelle gerückt, ist korrigiert.

Jetzt erstellt er mir bei Zeile 22 leider immer eine (Text-)Zelle mit Inhalt =SUBSTITUTE(RC[-1]," " & RC[-2],"")
Folglich setzt er bei der Spalte F (alles Standard-Zellen) alles auf FALSCH
Wenn ich weiter debugge erhalte ich bei Zeile 32 den Fehler Laufzeitfehler 1004 - Anwendungs- oder objektdefinierter Fehler

Naj, ein bisschen musst du auch noch selbst machen, das ist hier ja keine Auftragswerkstatt...
Die Vorlage habe ich dir geliefert, ich werd mich wohl kaum nochmal extra hinsetzen und testen. Außer du blechst mich dafür

Ist ja gut OK, ich seh es mir an!

Danke dir trotzdem mal für den Input!

German Question VB for Applications Development