Ich habe ein Makro wo ich einen Bereich Kopiere und den Inhalt wieder einfüge.
Nun möchte ich, dass dieses Makro pro Woche nur einmal Ausgeführt werden kann, oder nur einmal Automatisch ausgeführt wird.
Gibt es da eine Lösung?
Danke und Gruss Pius
Ich habe ein Makro wo ich einen Bereich Kopiere und den Inhalt wieder einfüge.
Nun möchte ich, dass dieses Makro pro Woche nur einmal Ausgeführt werden kann, oder nur einmal Automatisch ausgeführt wird.
Gibt es da eine Lösung?
Danke und Gruss Pius
Es wird geprüft, ob der Wert in A1 (die KW)
entsprechend kleiner ist...
Bye
Nike
Danke für deinen Code
nun habe ich ein weiteres Problem
in der gleichen Tabelle habe ich über VBA bedingte Formatierungen zugewiesen.
If Target.Value = 13 Then
Target.Interior.ColorIndex = 56
Target.Font.ColorIndex = 1
'Target.Interior.Pattern = xlSolid
End If
If Target.Value = "A" Then
Target.Interior.ColorIndex = 2
Target.Font.ColorIndex = 1
'Target.Interior.Pattern = xlSolid
........
wenn ich nun eine einzelne Zelle Kopiere und an einer anderen stelle einfüge wird die Formatierung übernomen
Wenn ich allerdings den ganzen Bereich Kopiere
werden wohl die Werte übernommen nicht aber die Formatierung.
hast du eine Lösung
Danke Pius
Bye
Nike
So
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
If Target.Value = 13 Then
Target.Interior.ColorIndex = 56
Target.Font.ColorIndex = 1
'Target.Interior.Pattern = xlSolid
End If
........
Fehler:
If Err.Number = 13 Then
Selection.Interior.ColorIndex = 35 ' Hier den Farbwert für Deinen Hintergrund einsetzen
Selection.Font.ColorIndex = 1
ActiveSheet.Protect ' Besser so: ActiveSheet.Protect ("Passwort")
Exit Sub
Else
MsgBox "Fehler: " & Err.Description, vbCritical, "Fehler..."
End If
Ansonsten kann ich`s nicht erklären...
Bye
Nike
Ich 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
If ISOWeek(Date) <= Worksheets(1).Range("O3") Then
Else
Worksheets(1).Range("O3") = ISOWeek(Now())
'restlicher Code der einmal laufen soll
Range("T6:BL50").Cut
Worksheets("Tabelle1").Range("O6:BG50").PasteSpecial Paste:=xlFormats, OTabelle1ration:=xlNone, SkipBlanks:= _
Range("BC6:BG50").Copy
Worksheets("Tabelle1").Range("BH6").PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Ansonsten müßte man sich die Datei mal im Ganzen anschaun,
nur hab ich heute leider nich die Möglichkeit hier...
Bye
Nike
so das kopieren funktioniuert jetzt
Das Berechnen war nicht auf Automatisch gestellt.
Nun habe ich das System Datum um eine Woche verändert. Leider wird da noch kein makro gestartet.
Die Funktion habe ich übrigen eingefügt
Vielleicht habe ich den Bezug noch Falsch
A5 = Heute()
O5 = =KÜRZEN($A$5-WOCHENTAG($A$5;2)+1)
P5 = O5+1 Q5 = P5+1......
O3 = Weeknum(O5)
In deinem Code verweise ich jetz auf O3
Stimmt das so
Pius
Klassisches Debugging halt.
Bye
Nike