VBA Funktion mit Button EIN/AUs schalten
11.01.2023 15:16:24
oliver
ich bin neu und habe von VBA fast keine Ahnung und hoffe das mir hier jemand helfen kann.
Ich habe eine VBA Code in meine exceltabelle kopiert mit der ich beim anklicken einer Zelle die ganze Zeile markiere ohne die Formatierung zu überschreiben. Da ich diese Funktion aber nicht jedes mal benötige, möchte ich diese gerne mit einem Button ein und ausschalten können. Kann mir jemand hierbei bei helfen und zeigen wie das geht?
hier der Code
Dim r As Integer, c As Integer, rng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Farbe As Long
Farbe = ActiveWorkbook.Colors(14) '=Colorindex 14 oder z.B. Farbe = 123456
'Ausführung in den Hintergrund schalten
Application.ScreenUpdating = False
Application.EnableEvents = False
'Hilfssheet zum Speichern des Zeilenformats anlegen
On Error Resume Next
If Sheets("Formatspeicher").Name = "" Then
Set fsp = Sheets.Add(After:=Sheets(Sheets.Count))
fsp.Name = "Formatspeicher"
Me.Select
fsp.Visible = False
Else: Set fsp = Sheets("Formatspeicher"): End If
'prüfen ob Hintergrundfarbe absichtlich geändert wurde und übernehmen dieser
If Not rng Is Nothing Then
If rng.Cells(1).Interior.Color Farbe Then
With fsp.Range(fsp.Cells(1, rng.Column), fsp.Cells(rng.Rows.Count, rng.Column _
+ rng.Columns.Count - 1)).Interior 'geänderte Farbe in die Kopie übernehmen
If rng.Cells(1).Interior.ColorIndex = xlNone Then .ColorIndex = xlNone _
Else .Color = rng.Cells(1).Interior.Color
End With
End If
End If
If r Target.Row Then 'Wenn Zeile ungleich vorheriger Selection
If r > 0 Then
fsp.Rows(1 & ":" & c).Copy 'Holen aus Formatspeicher
Rows(r & ":" & r + c - 1).PasteSpecial xlPasteFormats 'Format wiederherstellen
Target.Select
End If
r = Target.Row: c = Target.Rows.Count 'Merken welche Zeile aktuell ist
Rows(r & ":" & r + c - 1).Copy 'Zeilenformat kopieren und
fsp.Rows(1 & ":" & c).PasteSpecial xlPasteFormats 'im Formatspeicher ablegen
Rows(r & ":" & r + c - 1).Interior.Color = Farbe 'Zeilenhintergrund einheitlich
End If
Set rng = Target
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Gruß Olli