Re: Makro pro Woche nur einmal ausführen
28.04.2003 13:50:59
Pius
HAllo NikeIch sende Dir mal den ganzen Code, Irgendwie verlässt das ganze mein VBA wissen in eine höhere Stufe
Diese Arbeitsmappe
Option Explicit
Dim datname As String
Private Sub Workbook_OTabelle1n()
AddIns("Automatisches STabelle1ichern").Installed = False 'Automatsches sTabelle1icher ausschalten
ChDir "O:\POOL\PPS\"
ActiveWorkbook.Save
datname = Sheets("Tabelle1").Range("A2").Value
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "O:\POOL\PPS\" & datname & ".xls"
'Application.DisplayAlerts = False
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
AddIns("Analyse-Funktionen").Installed = True
AddIns("Analyse-Funktionen - VBA").Installed = True
AddIns("Bericht-Manager").Installed = True
Application.ScreenUpdating = False
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.Colors(4) = RGB(204, 255, 153)
ActiveWorkbook.Colors(5) = RGB(51, 102, 255)
ActiveWorkbook.Colors(6) = RGB(255, 255, 153)
.......
Application.ScreenUpdating = True
End Sub
Tabelle
Private Sub Workbook_BeforeClose(Cancel As Boolean)
datname = Sheets("Tabelle1").Range("A2").Value
Application.DisplayAlerts = False
ChDir "O:\POOL\PPS\"
ActiveWorkbook.SaveAs "O:\POOL\PPS\" & datname & ".xls"
'Application.DisplayAlerts = True
End Sub
Option Explicit
Private Sub CommandButton2_Click()
ActiveSheet.Unprotect
Selection.Interior.ColorIndex = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
ActiveSheet.Protect
End Sub
Private Sub CommandButton4_Click()
ActiveSheet.Unprotect
Selection.Interior.ColorIndex = 19
Selection.HorizontalAlignment = xlCenter
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
ActiveCell.FormulaR1C1 = "O"
ActiveSheet.Protect
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect
If Intersect(Target, Range("N5:BK5")) Is Nothing Then Exit Sub
Range(Cells(6, Target.Column), Cells(50, Target.Column)).Interior.Color = RGB(250, 250, 200)
Cancel = True
ActiveSheet.Protect
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect
If Intersect(Target, Range("N5:BK5")) Is Nothing Then Exit Sub
Range(Cells(6, Target.Column), Cells(50, Target.Column)).Interior.Color = RGB(198, 239, 193)
Cancel = True
ActiveSheet.Protect
End Sub
Private Sub CommandButton1_Click()
UserForm4.Show
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim EBereich As Range
Dim Fehler As String
Set EBereich = Range("O6:BL50")
If Intersect(Target, EBereich) Is Nothing Then Exit Sub
ActiveSheet.Unprotect
If ISOWeek(Date) <= Worksheets(1).Range("O3") Then
Else
Worksheets(1).Range("O3") = ISOWeek(Now())
'restlicher Code der einmal laufen soll
Range("T6:BL50").Select
Selection.Cut
Range("O6:BG50").Select
ActiveSheet.Paste
Selection.PasteSTabelle1cial Paste:=xlFormats, OTabelle1ration:=xlNone, SkipBlanks:= _
Range("BC6:BG50").Select
Selection.Copy
Range("BH6").Select
Selection.PasteSTabelle1cial Paste:=xlFormats, OTabelle1ration:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Application.CutCopyMode = False
On Error GoTo Fehler
If Target.Value = 5 Then
Target.Interior.ColorIndex = 36
Target.Font.ColorIndex = 1
'Target.Interior.Pattern = xlSolid
End If