ExcelTweaks: January 2013

Option Explicit
 
' Import
Private Declare Function UnhookWindowsHookEx Lib "user32" _
    (ByVal hHook As Long) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
 
Private Declare Function SetWindowsHookEx Lib "user32" _
    Alias "SetWindowsHookExA" _
    (ByVal idHook As Long, _
     ByVal lpfn As Long, _
     ByVal hmod As Long, _
     ByVal dwThreadId As Long) As Long
 
Private Declare Function SetWindowPos Lib "user32" _
    (ByVal hwnd As Long, _
     ByVal hWndInsertAfter As Long, _
     ByVal x As Long, _
     ByVal y As Long, _
     ByVal cx As Long, _
     ByVal cy As Long, _
     ByVal wFlags As Long) As Long
 
' Handle to the Hook procedure
Private hHook As Long
 
' Position
Private msgbox_x As Long
Private msgbox_y As Long
 
' Hook type
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
 
' SetWindowPos Flags
Private Const SWP_NOSIZE = &H1      ' Retains the current size
Private Const SWP_NOZORDER = &H4    ' Retains the current Z order

Sub TestMsgBox()
    MsgBoxPos "Set non-Center Position", _
              vbOKOnly, _
              "Message Box Hooking", _
              400, 300
End Sub
 
Public Sub MsgBoxPos(strPromt As String, _
              vbButtons As VbMsgBoxStyle, _
              strTitle As String, _
              xPos As Long, _
              yPos As Long)
 
    ' Store position
    msgbox_x = xPos
    msgbox_y = yPos
 
    ' Set Hook
    hHook = SetWindowsHookEx(WH_CBT, _
                              AddressOf MsgBoxHookProc, _
                              0, _
                              GetCurrentThreadId)
 
    ' Run MessageBox
    MsgBox strPromt, vbButtons, strTitle
End Sub
 
Private Function MsgBoxHookProc(ByVal lMsg As Long, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long) As Long
    If lMsg = HCBT_ACTIVATE Then
        ' Change position
        SetWindowPos wParam, 0, msgbox_x, msgbox_y, _
                     0, 0, SWP_NOSIZE + SWP_NOZORDER
 
        ' Release the Hook
        UnhookWindowsHookEx hHook
    End If
 
    MsgBoxHookProc = False
End Function

Using InputBox Method in Excel VBA

This summary is not available. Please click here to view the post.

Disable Alert (Warning) Messages in Excel

This summary is not available. Please click here to view the post.

Saturday, January 19, 2013

How To Store Current Range Selection using VBA in Excel?

Q. How To Store Current Selection using VBA in Excel?

A. Use the foloowing VBA script:

Option Explicit
Private Sub Example()
    Dim ActSheet As Worksheet
    Dim SelRange As Range
 
    Set ActSheet = ActiveSheet
    Set SelRange = Selection
 
    '' Any code here
    'Dim NewSheet As Worksheet
    '
    'ActiveSheet.Range("A1").Select
    '
    'Set NewSheet = ThisWorkbook.Sheets().Add()
    'NewSheet.Move After:=Sheets(ThisWorkbook.Sheets().Count)

    ActSheet.Select
    SelRange.Select
End Sub

Let's discuss how it works. First, force explicit declaration of all variables:

Option Explicit

To store selection we need two variables (Worksheet and Range):

Dim ActSheet As Worksheet
Dim SelRange As Range

Then we store active Worksheet and current range selection:

Set ActSheet = ActiveSheet
Set SelRange = Selection

Now we can use any VBA code (add new sheets, select or hide cells etc) and then restore origin selection:

ActSheet.Select
SelRange.Select

Save Workbook as New File using VBA in Excel

Q. How Save Workbook as New File? A. Use the following VBA code:

Private Sub SaveWorkbookAsNewFile(NewFileName As String)
    Dim ActSheet As Worksheet
    Dim ActBook As Workbook
    Dim CurrentFile As String
    Dim NewFileType As String
    Dim NewFile As String
 
    Application.ScreenUpdating = False    ' Prevents screen refreshing.

    CurrentFile = ThisWorkbook.FullName
 
    NewFileType = "Excel Files 1997-2003 (*.xls), *.xls," & _
               "Excel Files 2007 (*.xlsx), *.xlsx," & _
               "All files (*.*), *.*"
 
    NewFile = Application.GetSaveAsFilename( _
        InitialFileName:=NewFileName, _
        fileFilter:=NewFileType)
 
    If NewFile <> "" And NewFile <> "False" Then
        ActiveWorkbook.SaveAs Filename:= NewFile, _
            FileFormat:=xlNormal, _
            Password:="", _
            WriteResPassword:="", _
            ReadOnlyRecommended:=False, _
            CreateBackup:=False
 
        Set ActBook = ActiveWorkbook
        Workbooks.Open CurrentFile
        ActBook.Close
    End If
 
    Application.ScreenUpdating = True
End Sub

How does it work? Let's look inside.

First, turn off screen updating:
```
Application.ScreenUpdating = False
```
```
 
```
```
 
```
Store the opened file full path:
```
CurrentFile = ThisWorkbook.FullName
```
Open window to choose new filename and folder:

NewFile = Application.GetSaveAsFilename( _
    InitialFileName:=NewFileName, _
    fileFilter:=NewFileType)

And now save file as new Workbook:

ActiveWorkbook.SaveAs Filename:= NewFile, _
    FileFormat:=xlNormal, _
    Password:="", _
    WriteResPassword:="", _
    ReadOnlyRecommended:=False, _
    CreateBackup:=False

We have to close new file and open the origin workbook:

Set ActBook = ActiveWorkbook
Workbooks.Open CurrentFile
ActBook.Close

and turn on screen updating:
```
Application.ScreenUpdating = True
```

Using Intersection to Create a Range in Excel VBA

Example selects the Intersection of 2 Ranges (A1:D5 and C3:C10). If the Intersection is blank, the example displays a message box:

Private Sub UseIntersection()
    IntersectRanges Range("A1:D5"), Range("C3:C10")
End Sub
 
Private Sub IntersectRanges(range1 As Range, range2 As Range)
    Dim intRange As Range
 
    ' Application.Intersect Method
    Set intRange = Application.Intersect(range1, range2)
 
    If intRange Is Nothing Then
        ' No Intersection
        MsgBox "Ranges Do Not Intersect!"
    Else
        ' Show new Range's address
        MsgBox (intRange.Address)
 
        ' Select new Range
        intRange.Select
    End If
End Sub

Excel VBA: SmartDel Macro

This summary is not available. Please click here to view the post.

Screen Updating/Flash using VBA in Excel

This summary is not available. Please click here to view the post.

Friday, January 11, 2013

Who Knew Excel Could Do That? Ten Top Tips

This summary is not available. Please click here to view the post.