XLSX ohne Makros speichern
18.12.2017 23:07:56
Sabrina
vor vielen Jahren habe ich Dank dieses Forums ein gut funktionierendes Projekt erstellenh können. Die Version war Excel 2003 = xlt
Rechnungsvorlage ist xlt, per Button wird diese als xls geöffnet. Beim Drucken wird eine fortlaufende Rechnungsnummer vergeben und relevante Daten werden in eine separate Tabelle untereinander geschrieben. Funktioniert einwandfrei.
Nun muss ich diese Vorlage als .xlsm abspeichern. Das Öffnen als .xlsx kriege ich per Makro noch hin (aufgezeichnet) aber beim Speichern erscheint die Meldung "... Die folgenden Features können in Arbeitsmappen ohne Makros nicht gespeichert werden:
VB Projekt ..."
Ich habe versucht, die Meldung mit: Application.DisplayAlerts = False zu unterdrücken, aber es funktioniert einfach nicht.
Ich weiß einfach nicht, wie ich den Code ändern muss. Könnt ihr mir bitte helfen?
Vielen Dank schon mal
VG Sabrina
Option Explicit
Private Sub Workbook_Open() 'Rechnung
ChDir "C:\Vorlagen"
Workbooks.Open FileName:="C:\Vorlagen\Tabelle.xls"
Windows(1).Activate
Dim myWorksheet As Worksheet 'Passwort aufheben und Formatierungen zulassen
For Each myWorksheet In ThisWorkbook.Worksheets
myWorksheet.Protect Password:="meier", UserInterFaceOnly:=True, DrawingObjects:=True, _
Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowInsertingRows:=True, AllowDeletingRows _
:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Next
Dim Datum As String
Datum = Format(Now, "dd.mm.yyyy")
Range("F12") = Datum
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
On Error GoTo R_Error
Dim newNr As Variant, oldNr As Variant
Dim FileName As String
FileName = "C:\Rechnung.ini"
If Range("B14") "" Then Exit Sub
Close #1
restart:
Open FileName For Input As #1
Line Input #1, oldNr
Close #1
newNr = oldNr + 1
Open FileName For Output As #1
Write #1, newNr
Close #1
Select Case Len(newNr)
Case 1
newNr = "000" & newNr
Case 2
newNr = "00" & newNr
Case 3
newNr = "0" & newNr
Case 4
newNr = newNr
Case 5
MsgBox "Zahlenlimit überschritten"
Exit Sub
End Select
Range("B14") = newNr & "-17 A"
R_Exit:
Exit Sub
R_Error:
Select Case Err
Case 53
Open FileName For Output As #1
Close #1
Open FileName For Output As #1
Write #1, 0
Close #1
Err.Clear
Resume restart
Case 54
Close #1
Resume restart
Case Else
MsgBox Err & ": " & Err.Description
Resume R_Exit
End Select
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Workbooks("Tabelle.xls").Activate
ActiveWorkbook.Worksheets("Tabelle1").Unprotect "mueller"
Windows(1).Activate
If Range("B14") "" Then
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim iRow As Integer
Dim chkStr As String
Set wksSource = Worksheets("Rechnung")
Set wksTarget = Workbooks("Tabelle.xls").Worksheets(1)
chkStr = wksSource.Range("A11").Value
iRow = wksTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
wksTarget.Cells(iRow, 1).Value = wksSource.Range("B14").Value
wksTarget.Cells(iRow, 2).Value = wksSource.Range("F12").Value
wksTarget.Cells(iRow, 5).Value = wksSource.Range("B18").Value
wksTarget.Cells(iRow, 6).Value = wksSource.Range("B17").Value
wksTarget.Cells(iRow, 7).Value = wksSource.Range("F18").Value
wksTarget.Cells(iRow, 8).Value = wksSource.Range("F30").Value
wksTarget.Cells(iRow, 9).Value = wksSource.Range("F13").Value
wksTarget.Cells(iRow, 3).Value = Left(chkStr, InStr(1, chkStr, Chr$(10)) - 1)
chkStr = Right(chkStr, Len(chkStr) - InStr(1, chkStr, Chr$(10)))
wksTarget.Cells(iRow, 4).Value = Left(chkStr, InStr(1, chkStr, Chr$(10)) - 1)
End If
Workbooks("Tabelle.xls").Activate
ActiveWorkbook.Worksheets("Tabelle1").Protect "mueller"
ActiveWorkbook.Close SaveChanges:=True
If ThisWorkbook.Name = "Rechnung.xlt" Then
Exit Sub
Else
Dim vbc As Object
With ActiveWorkbook.VBProject
For Each vbc In .VBComponents
Select Case vbc.Type
Case 1, 2, 3: .VBComponents.Remove .VBComponents(vbc.Name)
Case 100
With vbc.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
End With
End If
End Sub
Anzeige