Scroll through worksheets with mouse wheel

S

SebastianHuang

New Member
Joined
Dec 5, 2019
Messages
38
Office Version
  1. 2013
Platform
  1. Windows
A co-worker of mine has the ability to switch between sheets in Excel super quickly by holding shift and using his mouse wheel. He was able to do this for all of his spreadsheets which makes me think it's an Add-In but I haven't been able to find anything like it.

I asked him how he did it; he had no idea -- it was installed on his computer years ago by somebody who no longer worked in the office.

Is there a way to enable this function?

What would be the vba code for it?
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Do a search for 'WM_MOUSEWHEEL' and you will find many examples
 
Upvote 0
Jaafar Tribak said:
Do a search for 'WM_MOUSEWHEEL' and you will find many examples
Click to expand...
I tried searching for them. The topics discussed were too complicated. I couldn't really understand what they were talking about and they seemed to be talking about different topics.
 
Upvote 0
I suppose you are aware that you can quickly switch between worksheets using the keyborad via (Ctrl + PageUp/PageDown)
 
Upvote 0
1- Code in a Standard Module:
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If Win64 Then
    Private Type MSG
        hwnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If
  
#If VBA7 Then
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

#Else
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
#End If

Private bEnable As Boolean


Public Property Let EnableWheelScroll(ByVal Enable As Boolean)

    Const WM_MOUSEWHEEL = &H20A
    Const WHEEL_DELTA = 120
    Const PM_REMOVE = &H1
    Const MK_SHIFT = &H4
  
    Dim tMsg As MSG
    Dim oTempSheet As Worksheet
  
    bEnable = Enable
    Do While bEnable
        If GetActiveWindow = Application.hwnd Then
            Call WaitMessage
            If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                If loword(CLng(tMsg.wParam)) = MK_SHIFT Then
                    If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then
                        Set oTempSheet = ActiveSheet.Next
                        If oTempSheet Is Nothing Then
                            Set oTempSheet = Sheets(1)
                        End If
                        oTempSheet.Activate
                    Else
                        Set oTempSheet = ActiveSheet.Previous
                        If oTempSheet Is Nothing Then
                            Set oTempSheet = Sheets(Sheets.Count)
                        End If
                        oTempSheet.Activate
                    End If
                Else
                    With tMsg
                        Call PostMessage(.hwnd, .message, .wParam, .lParam)
                    End With
                End If
            End If
        End If
        DoEvents
    Loop

End Property


Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function



2- Code in ThisWorkbook Module:
VBA Code: 
Option Explicit

Private Sub Workbook_Open()
    Application.OnTime Now, "'" & Me.CodeName & ".SetHook " & True & "'"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    SetHook False
End Sub

Private Sub SetHook(ByVal bHook As Boolean)
    EnableWheelScroll = bHook
End Sub

The above works but the continious running background loop has an impact performance plus freezes vbe .

Anyway, give the code a try and let me know - If you are happy with it, I'll write a similar code (mouse hook instead of PeekMessage API) that is ran from a remote excel process so it doesn't freeze the vbe or slows down excel.
 
Upvote 0
Jaafar Tribak said:
1- Code in a Standard Module:
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If Win64 Then
    Private Type MSG
        hwnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If
 
#If VBA7 Then
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

#Else
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
#End If

Private bEnable As Boolean


Public Property Let EnableWheelScroll(ByVal Enable As Boolean)

    Const WM_MOUSEWHEEL = &H20A
    Const WHEEL_DELTA = 120
    Const PM_REMOVE = &H1
    Const MK_SHIFT = &H4
 
    Dim tMsg As MSG
    Dim oTempSheet As Worksheet
 
    bEnable = Enable
    Do While bEnable
        If GetActiveWindow = Application.hwnd Then
            Call WaitMessage
            If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                If loword(CLng(tMsg.wParam)) = MK_SHIFT Then
                    If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then
                        Set oTempSheet = ActiveSheet.Next
                        If oTempSheet Is Nothing Then
                            Set oTempSheet = Sheets(1)
                        End If
                        oTempSheet.Activate
                    Else
                        Set oTempSheet = ActiveSheet.Previous
                        If oTempSheet Is Nothing Then
                            Set oTempSheet = Sheets(Sheets.Count)
                        End If
                        oTempSheet.Activate
                    End If
                Else
                    With tMsg
                        Call PostMessage(.hwnd, .message, .wParam, .lParam)
                    End With
                End If
            End If
        End If
        DoEvents
    Loop

End Property


Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function



2- Code in ThisWorkbook Module:
VBA Code: 
Option Explicit

Private Sub Workbook_Open()
    Application.OnTime Now, "'" & Me.CodeName & ".SetHook " & True & "'"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    SetHook False
End Sub

Private Sub SetHook(ByVal bHook As Boolean)
    EnableWheelScroll = bHook
End Sub

The above works but the continious running background loop has an impact performance plus freezes vbe .

Anyway, give the code a try and let me know - If you are happy with it, I'll write a similar code (mouse hook instead of PeekMessage API) that is ran from a remote excel process so it doesn't freeze the vbe or slows down excel.
Click to expand...
Just had a chance to test it today. It doesn't work.. I just created a new macro and replaced the code with the code in standard module. The shift plus mousewheel to scroll through worksheets doesn't work.
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If Win64 Then
    Private Type MSG
        hwnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If
 
#If VBA7 Then
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

#Else
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
#End If

Private bEnable As Boolean


Public Property Let EnableWheelScroll(ByVal Enable As Boolean)

    Const WM_MOUSEWHEEL = &H20A
    Const WHEEL_DELTA = 120
    Const PM_REMOVE = &H1
    Const MK_SHIFT = &H4
 
    Dim tMsg As MSG
    Dim oTempSheet As Worksheet
 
    bEnable = Enable
    Do While bEnable
        If GetActiveWindow = Application.hwnd Then
            Call WaitMessage
            If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                If loword(CLng(tMsg.wParam)) = MK_SHIFT Then
                    If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then
                        Set oTempSheet = ActiveSheet.Next
                        If oTempSheet Is Nothing Then
                            Set oTempSheet = Sheets(1)
                        End If
                        oTempSheet.Activate
                    Else
                        Set oTempSheet = ActiveSheet.Previous
                        If oTempSheet Is Nothing Then
                            Set oTempSheet = Sheets(Sheets.Count)
                        End If
                        oTempSheet.Activate
                    End If
                Else
                    With tMsg
                        Call PostMessage(.hwnd, .message, .wParam, .lParam)
                    End With
                End If
            End If
        End If
        DoEvents
    Loop

End Property


Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function
 
Upvote 0
Did you see this ?
www.mrexcel.com

Safe MouseWheel Event Hook (Addin)

Hi dear forum, In the past few months, I have posted various codes which show how to run code upon wheelmouse-scrolling. Basically, intercepting the mouse scroll event relies on four known techniques : Subclassing, Installing a windows Mouse Hook, using the SetWinEventHook API or using the...
www.mrexcel.com www.mrexcel.com

Install the addin and use the first code example in the second post in the above thread.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Can't scroll with mouse wheel on specific sheet after deleting a column on that sheet
Replies
0
Views
3K
sn0skier
S
D
  • Question
Vertical Scroll Bar fake copy?
Replies
1
Views
723
Anthony47
A
Oakie_Uffda
  • Question
Split Cell into multiple without splitting words and print decent
Replies
1
Views
1K
Oakie_Uffda
Oakie_Uffda
L
  • Question
VBA works on work PC but not home PC
Replies
3
Views
2K
rollis13
rollis13
F
  • Question
Office Uninstalled Itself
Replies
1
Views
2K
mole999
mole999

Forum statistics

Threads
1,215,417
Messages
6,124,791
Members
449,188
Latest member
Hoffk036

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top