Solved: Macro "Stautsbar" from ThisWorkbook i want for whole excel

[danovkos]

Hi all,
pls. i have one macro in Workbook "TestA" in ThisWorkbook part "SheetSelectionChange", which works for one opened workbook. But i want to make from this a universal macro , that will works for all opened workbooks of any users. Of course it will works only if user will have opened this "TestA" workbook.

Is it possible and is it hard to do this?

my code:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal target As Range)
Dim statusLine As String
Dim lookFor As Range
Dim rng As Range
Dim col As Integer
Dim found As Variant
Dim found2 As Variant
Dim found3 As Variant
Dim found4 As Variant
'Do
'Loop
If IsNumeric(target) = False Then
    Application.StatusBar = "Ready"
    On Error Resume Next
    With Application.WorksheetFunction
           statusLine = "Suma=" & Format(.Subtotal(109, target), "##,##0.00")
           statusLine = statusLine & "     Priemer=" & Format(Round(.Subtotal(101, target), 1), "##,##0.00")
           statusLine = statusLine & "     Počet=" & .Subtotal(103, target)
    End With
 
End If
  On Error GoTo koniec
 
If IsNumeric(target) = True Then
    With Application.WorksheetFunction
 
        ' Set lookFor = Sheets("Sheet2").Range("A1")
        Set lookFor = target
        Set rng = Sheets("piv all").Columns("A:T")
 
        'On Error Resume Next
         On Error GoTo koniec
 
        If target.Cells.Count > 1 Or IsEmpty(target) Then Exit Sub
 
            found = "   ||||     Spávca=" & Application.VLookup(lookFor.Value, rng, 12, 0)
            found2 = "    Právnik=" & Application.VLookup(lookFor.Value, rng, 13, 0)
            found3 = "     Angaž.=" & Format(Application.VLookup(lookFor.Value, rng, 3, 0), "##,##0.00")
            found4 = "    Aktuálny CASH=" & Format(Application.VLookup(lookFor.Value, rng, 20, 0), "##,##0.00")
             On Error GoTo koniec
bez:
 
                statusLine = "Suma=" & Format(.Subtotal(109, target), "##,##0.00")
               statusLine = statusLine & "     Priemer=" & Format(Round(.Subtotal(101, target), 1), "##,##0.00")
               statusLine = statusLine & "     Počet=" & .Subtotal(103, target)
               statusLine = statusLine & (found)
               statusLine = statusLine & (found2)
               statusLine = statusLine & Format(found3, "##,##0.00")
               statusLine = statusLine & Format(found4, "##,##0.00")
 
   End With
End If
    'On Error GoTo 0
      On Error GoTo koniec
 
  Application.StatusBar = statusLine
koniec:
End Sub
'Private Sub Workbook_Deactivate()
'  Application.StatusBar = False
'End Sub

thx for help

[GTO]

Try:

In a new Class Module named clsExcelAppEvents :

Option Explicit
    
Public WithEvents App As Excel.Application
    
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
    MsgBox "Selection changed in " & Sh.Parent.Name & String(2, vbCrLf) & _
            "Your current code here...", 0, ""
End Sub

In the ThisWorkbook Module :

Option Explicit
    
Dim ExcelEvent As New clsExcelAppEvents
    
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set ExcelEvent.App = Nothing
End Sub
    
Private Sub Workbook_Open()
    Set ExcelEvent.App = Application
End Sub

Hope that helps,

Mark

[danovkos]

thx a lot for help
but
i insert callsmodule to my workbook TestA. Default name was Class1. I try it change to your defined name (clsExcelAppEvents ) but it return error : NOT A LEGAL OBJECT NAME. I tried change the name with Properties window in field (Name).

Whats wrong pls?

[GTO]

It is a legal name. Make sure you did not accidently place any spaces in it as you typed.

[danovkos]

It is a legal name. Make sure you did not accidently place any spaces in it as you typed.

of course that i had space in the name
sorry for my stupidity

now it works like a charm
thank you very much for help

[GTO]

of course that i had space in the name

If it is of any consolation, you will note how quickly that error jumped to my mind (I may have done the same thing a time or two )

[danovkos]

Hi GTO,
i used this solution, but after time i figured out, that it taked very slow filtering of my data. When i filtered my data without implement your codes and module it takes max. 1 sec. but after implementing this code it takes 10 or 12 sec. And now the problem. Because i dont want to ask you again and take you other time, i wanted only delete your codes and module (Class-event) and hoped, that it will return to old quick working but it didnt.
Do you have any idea why my data still filtering very slow? I removed Class-event and delete code what you wrote, but nothings helps.

thx for help
or other guys any suggestions?

[GTO]

Hi danovkos,

I do not see why it would slow down or speed up, depending on whether the event was fired from application level, or workbook level.

Are you sure you did not change any code from the way listed at #1?

Mark

[danovkos]

Yes, i changed it , because i needed it adapt to my conditions and my wb.
this is my final:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim statusLine As String
Dim lookFor As Range
Dim rng As Range
Dim col As Integer
Dim found As Variant
Dim found2 As Variant
Dim found3 As Variant
Dim found4 As Variant
Dim found5 As Variant
Dim found6 As Variant
Dim found7 As Variant
Dim found8 As Variant
Dim found9 As Variant
Dim found10 As Variant
Dim found11 As Variant
'If GetUserName() = "s203855" Then Exit Sub
'Do
'Loop
  On Error GoTo koniec
'With Application.WorksheetFunction
'found = "   ||||     Spávca=" & Application.VLookup(lookFor.Value, rng, 12, 0)
'End With
  On Error GoTo koniec
 
 If Target.Cells.Count = 1 Then
    If IsNumeric(Target) = True Then
        With Application.WorksheetFunction
          
            ' Set lookFor = Sheets("Sheet2").Range("A1")
            Set lookFor = Target
            Set rng = Workbooks("Prehlady2010.xls").Sheets("piv all").Columns("A:T")
            
            'On Error Resume Next
             On Error GoTo koniec
              
    '        If .Subtotal(103, Target) > 1 Then GoTo bez
            If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
            
              
                found = "Spávca=" & Application.VLookup(lookFor.Value, rng, 12, 0)
                found2 = " |  Právnik=" & Application.VLookup(lookFor.Value, rng, 13, 0)
                found3 = " |  Angaž.=" & Format(Application.VLookup(lookFor.Value, rng, 3, 0), "##,##0.00")
                found4 = " |  Aktuálny CASH=" & Format(Application.VLookup(lookFor.Value, rng, 20, 0), "##,##0.00")
                found5 = " |  KRIZ=" & Application.VLookup(lookFor.Value, rng, 10, 0)
                found6 = " |  krieš=" & Application.VLookup(lookFor.Value, rng, 8, 0)
                found7 = " |  DE=" & Application.VLookup(lookFor.Value, rng, 16, 0)
                found8 = " |  MesPrer=" & Format(Application.VLookup(lookFor.Value, rng, 14, 0), "mmmm yy")
                found9 = " |  Seg=" & Application.VLookup(lookFor.Value, rng, 6, 0)
                
                 On Error GoTo koniec
bez:
        
'                    statusLine = "Suma=" & Format(.Subtotal(109, Target), "##,##0.00")
'                    statusLine = statusLine & "     Priemer=" & Format(Round(.Subtotal(101, Target), 1), "##,##0.00")
'                    statusLine = statusLine & "     Počet=" & .Subtotal(103, Target)
                    statusLine = statusLine & (found)
                    statusLine = statusLine & (found2)
                    statusLine = statusLine & Format(found3, "##,##0.00")
                    statusLine = statusLine & Format(found4, "##,##0.00")
                    statusLine = statusLine & (found5)
                    statusLine = statusLine & (found6)
                    statusLine = statusLine & (found7)
                    statusLine = statusLine & (found8)
                    statusLine = statusLine & (found9)
            '       statusLine = statusLine & "                     SUMA v Sk=" & Format(.Subtotal(109, Target) * 30.126, "##,##0.00 " & "Sk")
            '       statusLine = statusLine & "; Min=" & .Min(Target)
            '       statusLine = statusLine & "; Max=" & .Max(Target)
            
       End With
    End If
End If
    'On Error GoTo 0
      On Error GoTo koniec
  
  Application.StatusBar = statusLine
koniec:
If IsError(Target) = False Then
    If IsNumeric(Target) = False Then
        Application.StatusBar = "Ready"
    '---------- nie je numerická hodnota v aktívnej bunke
        On Error Resume Next
        With Application.WorksheetFunction
               statusLine = "Suma=" & Format(.Subtotal(109, Target), "##,##0.00")
               statusLine = statusLine & "     Priemer=" & Format(Round(.Subtotal(101, Target), 1), "##,##0.00")
               statusLine = statusLine & "     Počet=" & .Subtotal(103, Target)
        End With
    '----------
    End If
End If

 Application.StatusBar = statusLine
End Sub