AW: versuche diese Version
27.07.2017 16:57:11
Tino
Hallo,
hier der Code
In den Zeilen kannst du die Zeile und die Spalten angeben wo auf 0 geprüft werden soll.
Option Explicit
Sub Save_Tabelle()
Dim n&
Dim SavePath$, sExtention$, sSaveFullPath$
Dim intKill%, intFormat%, booSave As Boolean
Dim varAusnahme
Const strSpalte0$ = "AM"
Const strZeile0$ = "23"
Const strPass$ = "Kosmos"
'Tabelle anpassen (Deckblatt)
varAusnahme = Array("Def_Split")
With ThisWorkbook
intFormat = .FileFormat
SavePath = .Path
SavePath = SavePath & IIf(Right$(SavePath, 1) <> "\", "\", "")
ChDrive SavePath
ChDir SavePath
SavePath = SavePath & Format(Date, "dd_mm_yyyy_")
sExtention = Right$(.Name, Len(.Name) - InStrRev(.Name, ".") + 1)
On Error GoTo ErrorHandler:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For n = 3 To .Sheets.Count
If .Sheets(n).Visible = True Then
If Not IsNumeric(Application.Match(.Sheets(n).Name, varAusnahme, 0)) Then
sSaveFullPath = SavePath & .Sheets(n).Name & sExtention
If Dir(sSaveFullPath, vbNormal) <> "" Then
If intKill = 0 Then
If MsgBox("Datei schon vorhanden. Diese löschen?", _
vbQuestion + vbYesNo) = vbYes Then
Kill sSaveFullPath: DoEvents
intKill = 1
booSave = True
Else: intKill = 2: booSave = False
End If
ElseIf intKill = 1 Then
Kill sSaveFullPath: DoEvents
booSave = True
End If
Else
booSave = True
End If
If booSave Then
Application.StatusBar = "Bearbeite: '" & .Sheets(n).Name & "'"
DoEvents
.Sheets(n).Copy
With ActiveWorkbook
.Sheets(1).Unprotect strPass
.Sheets(1).UsedRange.Value = .Sheets(1).UsedRange.Value
Call Loesche_0_AW(.Sheets(1), strZeile0, CStr(.Sheets(1).Columns(strSpalte0).Column))
.Sheets(1).Protect strPass
.SaveAs sSaveFullPath, intFormat
.Close False
End With
End If
End If
End If
Next n
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
End With
MsgBox "Alle aktionen abgeschlossen!", vbInformation
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, Err.Number
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub Loesche_0_AW(oWS As Worksheet, strZeile0$, strCol$)
Dim rng As Range
On Error Resume Next
With oWS.UsedRange.EntireRow
.Columns(.Columns.Count).FormulaR1C1 = "=IF((RC" & strCol & "=0)*(ROW()>=" & strZeile0 & "),TRUE,ROW())"
.Columns(.Columns.Count).Value = .Columns(.Columns.Count).Value
.Sort .Columns(.Columns.Count).Cells(1, 1), xlAscending, Header:=xlYes
Set rng = .Columns(.Columns.Count).SpecialCells(xlCellTypeConstants, 4)
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
.Columns(.Columns.Count).EntireColumn.Delete
End With
On Error GoTo 0
End Sub
Gruß Tino