Floating Button

[ExcelNeuling99]

Hallo zusammen,

ich suche gerade eine Lösung (die ich aber bisher noch nie gesehen habe).

und zwar habe ich in dem Beispieldokument einen Button mit Makro erstellt, der automatisch alle Filter zurücksetzt. Meine "working" Tabelle hat aber extrem viele Spalten und dadurch muss man seitlich lange zum Button scrollen. Daher wäre es optimal, wenn dieser Button "mitscrollt" und damit immer an der gleichen Stellen (oben links am Bildschirm) ist. Ist dies möglich?

Vielen Dank!

[WillWissen]

Hi,

schau mal in diesen Beitrag - ist das die Lösung? http://www.office-loesung.de/ftopic411266_0_0_asc.php

[shift-del]

Hallo

Warum nicht einfach die bereits eingebaute Lösung verwenden?

Symbolleiste für den Schnellzugriff anpassen -> Alle Befehle -> Alle Filter löschen -> Hinzufügen -> OK

[ExcelNeuling99]

Leider komme ich mit dem oben genannten Link nicht weiter. In dem dortigen Codebeispiel fehlen mir die Erklärungen:(

Das mit der Symbolleiste hat leider 2 Probleme:

1. Ich benutze einen Blattschutz, wodurch diese Funktion nicht mehr geht.
   
2. Verschiedene Benutzer haben Zugriff auf die Tabelle und nicht jeder wird sein Excel entsprechend einrichten.
   

[M.Wichmann]

Kannst du nicht einfach die Ansicht zb auf SpalteA fixieren? Wenn der Button da ist, ist er immer Sichtbar. Wenn das wirklich so in etwas deine Tabelle ist, wäre es ehh von Vorteile die Bauteilenummer immer zu sehen.

[Matthias84]

Hallo,

warum startest du dein Makro nicht über die Symbolleiste für den Schnellzugriff?

[Kuwer]

Leider komme ich mit dem oben genannten Link nicht weiter. In dem dortigen Codebeispiel fehlen mir die Erklärungen:(

Hallo,

auf Deine Beispielmappe bezogen dann so:

Microsoft Excel Objekt DieseArbeitsmappe

Option Explicit 

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 
ActiveSheet.Range("Tabelle1").ListObject.AutoFilter.ShowAllData 
ActiveSheet.Range("B1").Value = "" 
End Sub 

Private Sub Workbook_Activate() 
 If ActiveSheet.Name = "Tabelle1" Then Application.Run Me.Worksheets("Tabelle1").CodeName & ".Worksheet_Activate" 
End Sub 

Private Sub Workbook_Deactivate() 
 If ActiveSheet.Name = "Tabelle1" Then Application.Run Me.Worksheets("Tabelle1").CodeName & ".Worksheet_Deactivate" 
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 14 - mit VBAHTML 12.6.0

Microsoft Excel Objekt Tabelle1

Option Explicit 

Dim bolNoLoop As Boolean 
Dim datNext As Date 

Private Sub Worksheet_Change(ByVal Target As Range) 
Dim i, k As String 
Dim ArrWerte As Variant 
Dim n As Long 
If Target.Address = "$B$1" Then 
With ListObjects("Tabelle1") 
  k = Range("B1").Text 
  ArrWerte = .ListColumns(4).DataBodyRange 
  For n = 1 To Ubound(ArrWerte, 1) 
    If InStr(1, ArrWerte(n, 1), k, 1) Then i = i & " " & ArrWerte(n, 1) 
  Next n 
  If i <> "" Then 
    ArrWerte = Split(Mid(i, 2)) 
    ListObjects("Tabelle1").Range.AutoFilter Field:=4, Criteria1:=ArrWerte, Operator:=xlFilterValues 
  Else 
    ListObjects("Tabelle1").Range.AutoFilter Field:=4, Criteria1:="", Operator:=xlFilterValues 
  End If 
End With 
End If 
End Sub 

Private Sub Worksheet_Activate() 
 bolNoLoop = False 
 ButtonNachfuehren 
End Sub 

Private Sub Worksheet_Deactivate() 
 bolNoLoop = True 
 ButtonNachfuehren 
End Sub 

Private Sub ButtonNachfuehren() 
 If bolNoLoop = True Then 
   On Error Resume Next 
   Application.OnTime datNext, Me.CodeName & ".ButtonNachfuehren", True, False 
   On Error GoTo 0 
 Else 
   Me.Shapes("Rechteck 1").Top = ActiveWindow.VisibleRange.Top 
   Me.Shapes("Rechteck 1").Left = ActiveWindow.VisibleRange.Left 
   datNext = Now + TimeSerial(0, 0, 1) 
   Application.OnTime datNext, Me.CodeName & ".ButtonNachfuehren", False, True 
 End If 
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 14 - mit VBAHTML 12.6.0

  Tabelle über Suchfeld filtern_Kuwer.xlsm (Größe: 21,17 KB / Downloads: 6)

Gruß Uwe