Set objExcelApp = Nothing
    Set objExcelApp = CreateObject("Excel.Application")
    Set objworkbooks = objExcelApp.Workbooks
    objworkbooks.Open "F:\Analytik\Laborspezifisch\Labor" & _
      "Q1\Sonstiges\Visko\Vorlage.xls"
    objExcelApp.Visible = false
    ActiveSheet.Unprotect Password:="....."
 
      Cells(40, 3).Select
      ActiveCell = esd
 
      Cells(10, 6).Select
      ActiveCell = temp
 
      Cells(12, 3).Select
      ActiveCell = prd
 
      Cells(42, 3).Select
      ActiveCell = prf
 
      Cells(14, 3).Select
      If F = 34800 Then
      ActiveCell = "DIN 108"
      End If
 
      If F = 6500 Then
      ActiveCell = "DIN 114"
      End If
 
      If F = 1141 Then
      ActiveCell = "DIN 125"
      End If
 
      If F = 195.5 Then
      ActiveCell = "DIN 145"
      End If
 
 
 
   n = 0
     For i = UBound(FELD1) To anf Step -1
             Cells(36 - (15 - i), 4).Select
             ActiveCell = (Me.Controls("TextboxNeu" & CStr(i)))
             If ActiveCell.Value <> "" Then
             Cells(36 - (15 - i), 5).Select
             ActiveCell = FELD1((i), 1)
             End If
   n = n + i
     Next i
 
       ActiveSheet.PrintOut Copies:=1, Collate:=True
       objExcelApp.DisplayAlerts = False
       ChDir "F:\Analytik\Laborspezifisch\Labor Q1\Rohdaten\Viskosität\"
       ChDrive "F:\"
 
 
       ret = MsgBoxEx("wollen Sie speichern?" & vbNewLine & vbNewLine, _
                   "&Ja- &Nein*-", Icon_Question, "speichern")
 
                 If ret = 1 Then
                    If Not Folder.Exists(sOrdner) Then
                         MkDir (sOrdner)
                         ChDir (sOrdner)
                         ChDrive ("F:\")
                         ActiveWorkbook.SaveAs (sOrdner) & "\" & prd & ".xls"
                         ActiveWorkbook.Close
                         objExcelApp.Quit
                         Set objExcelApp = Nothing
                 End If
 
                        ret1 = MsgBoxEx("neue Berechnung durchführen?" & _
                          vbNewLine & vbNewLine, _
                              "&Ja- &Nein*-", Icon_Question, "neue Berechnung")
 
                        If ret1 = 2 Then
                            End
                        End If
 
                        If ret1 = 1 Then
                        objExcelApp.Quit
                            UnloadForms
                            Form1.Show
                        End If
                 End If