Sub DataTransfer(sID As String)
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 varID As Long
Dim NextID As Long
Dim nInstall As String
Dim nTech As String, nEqui As String, nTyp As String, nPTB As String, nSNR As String, nSicherungsart As String
Dim nFDSS As String, nEXGRP As String, nBetriebsdruck As String, nBetriebstemp As String, nEinbaulage As String
Dim nWirkrichtung As String, nFFA As String, nPMBAR As String, nVMBAR As String, nPVDTNG As String, nVVDTNG As String
Dim nMWRKST As String, nMedium As String, nHeizung As String, nIsolierung As String, nAccess As String
Dim nrow1 As Long
Const xlUp = -4162
Application.ScreenUpdating = False
Set xlApp = CreateObject("excel.Application")
Set xlWBook = xlApp.Workbooks.Open(ThisDocument.Path & "\artexGeräteliste.xlsx")
xlWBook.Application.Visible = True
xlWBook.Application.Sheets("Geräteübersicht").Select
Set ws = xlWBook.Sheets("Geräteübersicht")
If sID = "0" Then
nRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row + 1
NextID = xlApp.WorksheetFunction.Max(ws.Range("A:A")) + 1
ws.Cells(nRow, 1) = NextID
ActiveDocument.Variables("varID").Value = NextID
ActiveDocument.Save
Else
On Error Resume Next
nRow = xlApp.WorksheetFunction.Match(CLng(sID), ws.Range("A:A"), 0)
If nRow = 0 Then nRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row + 1
On Error GoTo 0
End If
ldfNr = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
If ldfNr = 0 Then
ws.Cells(ldfNr + 1, 2) = 1
Else
ws.Cells(ldfNr + 1, 2) = ldfNr - 2
End If
Cells(nRow, 1).RowHeight = 18
...
nrow1 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row - nRow
If nrow1 > 0 Then
Cells(nRow + 1, 2).Resize(nrow1).EntireRow.Delete
End If
Application.ScreenUpdating = True
xlWBook.Close SaveChanges:=True
Application.Quit SaveChanges:=True
End Sub