AW: Missetäter gefunden!
05.05.2019 19:31:43
Sepp
Hallo Michael,
deine Datei verhält sich bezüglich der Formate echt seltsam!
So sollte es klappen.
Sub BlattKopieren()
Dim strFileName As String, varLinks As Variant, lngindex As Long
'On Error GoTo ErrorHandler
strFileName = ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx"
If Dir(strFileName, vbNormal) <> "" Then
MsgBox "Datei existiert bereits!"
Else
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
ThisWorkbook.ActiveSheet.Copy
With ActiveWorkbook
With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
Call .DeleteLines(1, .CountOfLines)
End With
With .Sheets(1)
.ListObjects(1).Unlist
.UsedRange = .UsedRange.Value
On Error Resume Next
.UsedRange.SpecialCells(xlCellTypeAllValidation).Validation.Delete
Err.Clear
On Error GoTo ErrorHandler
.Cells(1, 1).Select
.Shapes("Rectangle 1").Delete
.Columns("B").NumberFormat = "#,##0.00 $;[Red] -#,##0.00 $"
.Columns("L:M").NumberFormat = "#,##0.00 $;[Red] -#,##0.00 $"
End With
Call .ApplyTheme(ThisWorkbook.FullName)
Call .SaveAs(Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook)
On Error Resume Next
varLinks = .LinkSources(xlLinkTypeExcelLinks)
For lngindex = 1 To Ubound(varLinks)
Call .BreakLink(varLinks(lngindex), xlLinkTypeExcelLinks)
Next
Err.Clear
On Error GoTo ErrorHandler
Call .Close(True)
End With
End If
ErrorHandler:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0