Hallo Experten,

ich habe ein problem damit, ein ListObjekt in der Größe zu verändern. bzw die ursprüngliche Größe nach einer Verkleinerung wiederherzustellen.

Mit dem Code generiere ich eine XML Datei, was soweit auch alles wunderbar funktioniert.

Es geht allein darum, die Messwerttabelle (ListObjekt) und die Busbereiche (ListObjekt) zur erstellung der XML Datei zu verkleinern (um in der XML leerzeilen zu vermeiden) und nach der Erstellung wieder auf die Ursprungsgröße zu vergrößern mittels Rezise Range.

Das verkleinern funzt einwandfrei, die Datei wird erstellt, nur am Ende wenn ich die Ausgangsgröße wiederherstellen will, kommt exakt folgende Fehlermeldung:

Laufzeitfehler '1004':

Die Zelle oder das Diagramm, die bzw. das Sie ändern möchten, ist schreibgeschützt.

Im code ziemlich weit unten, hab ich kenntlich gemacht, wo er immer abbricht.

Vielen Dank für eure Hilfe.

Sub subXMLExport()

        Dim AnzahlDatensätzeBB As String
        Dim AnzahlDatensätzeMW As String
        Sheets("Übersicht Datentypen & Steigung").Select
        AnzahlDatensätzeBB = Range("M15").Value
        AnzahlDatensätzeMW = Range("M9").Value

        Dim Zelle As Range
        Dim bAllesOkBB As Boolean
        
        Dim Status As Range
        Dim bAllesOkMW As Boolean
        
        Dim bStart As Boolean
        
        Dim sName As String
        Dim sFolder As String, FullDatNam As String
        
        Dim Zelle2 As String
    
    
'..... Prüfen auf Vollständigkeit der Busbereiche
        
        Sheets("4.Busbereiche").Select
        bAllesOkBB = True
        Range("D3:D" & AnzahlDatensätzeBB).Select
        For Each Zelle In Selection
        
        If Zelle.Value = "" Then
        
        bAllesOkBB = False
    
        'Else
        'bAllesOkBB = True
        End If
        Next
    
        If bAllesOkBB = True Then
    
        Else
        If MsgBox("Bei einem oder mehreren Busbereichen wurde kein DatenTyp angegeben! Trotzdem Fortfahren?", vbYesNo) = vbYes Then
    
        bAllesOkBB = True
    
        Else
    
        bAllesOkBB = False
    
        End If
        End If
        
        
'..... Prüfen auf Vollständigkeit der Messwerttabelle
        Sheets("5.Ausgabe").Select
        Range("P3:P" & AnzahlDatensätzeMW).Select
        bAllesOkMW = True
        For Each Status In Selection
        If Status.Value <> "OK" Then

        bAllesOkMW = False

        End If
        Next

        If bAllesOkMW = True Then

        Else
        If MsgBox("Ein oder mehrere Datensätze der Messwerttabelle sind fehlerhaft/nicht vollständig! Trotzdem Fortfahren?", vbYesNo) = vbYes Then

        bAllesOkMW = True

        Else

        bAllesOkMW = False

        End If
        End If


'...... Start Prüfen

        If bAllesOkBB = True And bAllesOkMW = True Then
        
        bStart = True
        
        Else
        
        bStart = False
        Sheets("5.Ausgabe").Select
        Zelle2 = "A3:D38"
        Range(Zelle2).Select
        
        End If

'..... Starten

        If bStart = True Then
        ActiveWorkbook.Unprotect "limon"
        Worksheets("5.Ausgabe").Unprotect Password:="limon"
        Worksheets("4.Busbereiche").Unprotect Password:="limon"
    
        Sheets("5.Ausgabe").ListObjects("Messwerte").Resize Range("E2:N" & AnzahlDatensätzeMW)
        Sheets("4.Busbereiche").ListObjects("Busbereiche").Resize Range("A2:E" & AnzahlDatensätzeBB)
        
        Const DatNam = "abc.xml"

        sName = Sheets("Start").Cells(11, 3)
        ' .....
        sFolder = Ordnerauswahl()
        If Len(sFolder) > 0 Then
             FullDatNam = sFolder & "\" & sName
        End If
    
          'An der stelle prüfen Ob datei bereits vorhanden
          If Dir(FullDatNam) = "" Then
            ActiveWorkbook.XmlMaps("Messgroessentabelle_Zuordnung").Export URL:=FullDatNam
            MsgBox "Datei " & sFolder & "\" & sName & " erzeugt"
         Else
         
           If MsgBox("Datei existiert bereits unter diesem Namen! Datei Ersetzen?", vbYesNo) = vbYes Then
            Kill FullDatNam
            ActiveWorkbook.XmlMaps("Messgroessentabelle_Zuordnung").Export URL:=FullDatNam
            MsgBox "Datei " & sFolder & "\" & sName & " überschrieben"
            Else
            End If
            
         End If
         
'.... ursprüngliche Größe wiederherstellen
         
         Sheets("5.Ausgabe").ListObjects("Messwerte").Resize Range("E2:N1502")
         Sheets("4.Busbereiche").ListObjects("Busbereiche").Resize Range("A2:E52")


'#####    Hier Springt er dann immer wieder raus und erzeugt den Fehler!


    Else
      MsgBox "Abbruch"
      Exit Sub
    End If
    
    ThisWorkbook.Sheets("4.Busbereiche").Protect "limon"
    ThisWorkbook.Sheets("5.Ausgabe").Protect "limon"
    
    Sheets("5.Ausgabe").Select
    Zelle2 = "A3:D38"
    Range(Zelle2).Select

End Sub