Guten Tag,

ich habe ein kleines Problem mit einem Makro. Zur Erklärung: Ich habe ein Word Formular erstellt das ein Modul enthält welches die in das Word Formular eingetragenen Daten in eine Excel Tabelle überträgt. Das ganze funktioniert auch wunderbar. Nun habe ich aber vor, das ganze etwas zu erweitern. Ein Kunde der mit diesen erstellten Excel Tabellen arbeiten bzw. ein Makro anwenden muß welches diese Daten wiederum ausliest und benötigte Ersatzteile auflistet, bemängelt das die erstellte Excel Tabelle usedRange Einträge erstellt die nicht vorhanden sein dürften. Normalerweise würde das vom Kunden ausgeführte Makro die zu bestellenden Ersatzteile mit einer leere Zeile Abstand, unter den aufgelisteten Daten eintragen. Allerdings passiert dies erst in Zeile 502. Das bedeutet das mein Makro aus irgend einem Grund 501 usedRange Einträge erstellt in denen aber nichts drin steht. Wenn ich mir mein Makro anschaue sehe ich nicht warum dies der Fall sein sollte.

Nun versuche ich dieses Problem damit zu lösen das mein Makro nachdem es die Daten aus dem Formular in die Tabelle übertragen hat und bevor diese Tabelle gespeichert und wieder geschlossen wird, alle leeren Zellen löschen soll. Allerdings löscht dieser Code dann auch leere Zellen die erwünscht sind und genau das versuche ich zu vermeiden, weis jedoch nicht genau wie ich das am besten anstelle.

Ich poste einmal das komplette Makro, damit man das mal genauer in Augenschein nehmen kann. Bitte nicht über die sehr lineare Programmierweise wundern, ich bin kein VBA Experte und versuch mir das ganze so einfach wie möglich zu machen.

Hier ist der Code zum auslesen und übertragen des Inhalts des Word Formulars an die Excel Tabelle:

Sub DataTransfer()
   Dim xlApp As Object
   Dim xlWBook As Object
   Dim fld As FormField
   Dim nRow As Long
   Dim nCol As Integer
   Dim ws As Object
   Dim ldfNr As Integer
   Dim rng As Range
   Const xlUp = -4162
   
    Application.ScreenUpdating = False
    
    Set xlApp = CreateObject("excel.Application")
    Set xlWBook = xlApp.Workbooks.Open(ThisDocument.Path & "\artexGeräteliste.xlsm")
    xlWBook.Application.Visible = True
    xlWBook.Application.Sheets("Geräteübersicht").Select
    Set ws = xlWBook.Sheets("Geräteübersicht")
    nRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row + 1
    ldfNr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    If ldfNr = 0 Then
    ws.Cells(ldfNr + 1, 1) = 1
    Else
    ws.Cells(ldfNr + 1, 1) = ldfNr - 2
    End If
    
    
    nInstall = ActiveDocument.FormFields("Gebäude").Result & " - " & ActiveDocument.FormFields("ObjNr").Result
    nEqui = ActiveDocument.FormFields("EquiNr").Result
    nTyp = ActiveDocument.FormFields("Typ").Result & "-" & ActiveDocument.FormFields("TypAdd1").Result & "-" & ActiveDocument.FormFields("TypAdd2").Result
    nPTB = ActiveDocument.FormFields("PTB").Result
    nSNR = ActiveDocument.FormFields("SNR").Result
    nFFA = ActiveDocument.FormFields("FFA").Result & " x " & ActiveDocument.FormFields("SW").Result & " / " & ActiveDocument.FormFields("ZWL").Result & " / " & ActiveDocument.FormFields("WR").Result
    nPMBAR = ActiveDocument.FormFields("PMBAR").Result
    nVMBAR = ActiveDocument.FormFields("VMBAR").Result
    nPVDTNG = ActiveDocument.FormFields("PVDTNG").Result
    nVVDTNG = ActiveDocument.FormFields("VVDTNG").Result
    nMWRKST = ActiveDocument.FormFields("MWRKST").Result
    nMedium = ActiveDocument.FormFields("Medium").Result
    
    xlWBook.Application.Cells(nRow, 2).Value = ActiveDocument.FormFields("Gebäude").Result & " - " & ActiveDocument.FormFields("ObjNr").Result
    xlWBook.Application.Cells(nRow, 2).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 3).Value = ActiveDocument.FormFields("EquiNr").Result
    xlWBook.Application.Cells(nRow, 3).HorizontalAlignment = xlCenter
    If ActiveDocument.FormFields("TypAdd1").Result = "" Then
    xlWBook.Application.Cells(nRow, 4).Value = ActiveDocument.FormFields("Typ").Result & "-" & ActiveDocument.FormFields("TypAdd2").Result
    xlWBook.Application.Cells(nRow, 4).HorizontalAlignment = xlCenter
    Else
    xlWBook.Application.Cells(nRow, 4).Value = ActiveDocument.FormFields("Typ").Result & "-" & ActiveDocument.FormFields("TypAdd1").Result & "-" & ActiveDocument.FormFields("TypAdd2").Result
    xlWBook.Application.Cells(nRow, 4).HorizontalAlignment = xlCenter
    End If
    xlWBook.Application.Cells(nRow, 7).Value = ActiveDocument.FormFields("PTB").Result
    xlWBook.Application.Cells(nRow, 7).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 9).Value = ActiveDocument.FormFields("SNR").Result
    xlWBook.Application.Cells(nRow, 9).HorizontalAlignment = xlCenter
    If ActiveDocument.FFNEIN.Value = True Then
    xlWBook.Application.Cells(nRow, 8).Value = "-"
    xlWBook.Application.Cells(nRow, 8).HorizontalAlignment = xlCenter
    Else
    xlWBook.Application.Cells(nRow, 8).Value = ActiveDocument.FormFields("FFA").Result & " x " & ActiveDocument.FormFields("SW").Result & " / " & ActiveDocument.FormFields("ZWL").Result & " / " & ActiveDocument.FormFields("WR").Result
    xlWBook.Application.Cells(nRow, 8).HorizontalAlignment = xlCenter
    End If
    xlWBook.Application.Cells(nRow, 13).Value = ActiveDocument.FormFields("PMBAR").Result
    xlWBook.Application.Cells(nRow, 13).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 14).Value = ActiveDocument.FormFields("VMBAR").Result
    xlWBook.Application.Cells(nRow, 14).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 15).Value = ActiveDocument.FormFields("PVDTNG").Result
    xlWBook.Application.Cells(nRow, 15).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 16).Value = ActiveDocument.FormFields("VVDTNG").Result
    xlWBook.Application.Cells(nRow, 16).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 17).Value = ActiveDocument.FormFields("MWRKST").Result
    xlWBook.Application.Cells(nRow, 17).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 18).Value = ActiveDocument.FormFields("Medium").Result
    xlWBook.Application.Cells(nRow, 18).HorizontalAlignment = xlCenter
    If ActiveDocument.ComboBox1.Text = "Armatur funktionssicher instandgesetzt." Then
        xlWBook.Application.Cells(nRow, 11).Value = "OK"
        xlWBook.Application.Cells(nRow, 11).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 11).Font.Color = RGB(34, 139, 34)
    End If
    
    If ActiveDocument.ComboBox1.Text = "Weitere Maßnahmen erforderlich. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 11).Value = "Beanstandet"
        xlWBook.Application.Cells(nRow, 11).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 11).Interior.Color = RGB(255, 255, 0)
        xlWBook.Application.Cells(nRow, 11).Font.Color = RGB(0, 0, 0)
    End If
    
    If ActiveDocument.ComboBox1.Text = "Wartung nicht möglich. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 11).Value = "ohne Wartung"
        xlWBook.Application.Cells(nRow, 11).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 11).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 11).Font.Color = RGB(0, 0, 0)
    End If
        
    If ActiveDocument.ComboBox1.Text = "Altarmatur - Zulassung zurückgezogen! (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 11).Value = "Altarmatur"
        xlWBook.Application.Cells(nRow, 11).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 11).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 11).Font.Color = RGB(0, 0, 0)
    End If
    
    If ActiveDocument.ComboBox1.Text = "Altarmatur - Zulassung eingeschränkt! (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 11).Value = "Altarmatur"
        xlWBook.Application.Cells(nRow, 11).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 11).Font.Color = RGB(34, 139, 34)
    End If
        
    If ActiveDocument.ComboBox1.Text = "Altarmatur - Zulassung eingeschränkt ! (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 11).Value = "Altarmatur"
        xlWBook.Application.Cells(nRow, 11).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 11).Interior.Color = RGB(255, 255, 0)
        xlWBook.Application.Cells(nRow, 11).Font.Color = RGB(0, 0, 0)
    End If
    

   For Each rng In ActiveSheet.UsedRange
      If IsEmpty(rng) Then rng.Delete xlShiftUp
   Next rng
   Application.ScreenUpdating = True
   xlWBook.Close SaveChanges:=True

    
End Sub

Der untere Teil "For Each rng..." soll die überflüssigen Zeilen löschen anschließend speichern und schließen.

Eventuell weiss jemand Rat wie ich es anstellen kann das das Makro nur die usedRange Einträge löscht, die sich unterhalb der Zeile befinden welche durch das Makro beim speichern ausgelesen und übertragen werden. Ich hoffe ich habe mein Problem ausreichend und verständlich genug geschildert und würde mich sehr freuen wenn sich jemand einmal damit beschäftigt und mir eventuell weiterhelfen kann.

Gruß

Manuel