Excel Macro Man

How to Create Addin

2010-12-11T21:41:00.000+05:30

Creating Add-ins in Excel

After much analysis I created my own steps to Create Excel Addin

Follow the below basic steps to create Addin -

Always use Workbook or Activeworkbook – don’t use Thisworkbook in coding
The Final Addin Should not have any sheets like – Raw file or data sheet
Have a blank Sheet and all the coding should refer to Workbook Object or Activeworkbook method
The Main Subroutine should be Public Sub Sub_name
All Functions should be Public Function FnName
All the modules should have specific names- select the module in Project Explorer View & Press F4 (properties) now enter a specific name for the module
Now select the VBA Project in Project Explorer view & Press F4 (Properties) and enter a specific name for the project. This step is required because if you leave the default name for the project it would be named as "VBAProject" and MS Excel would not allow you to enter duplicate addins with same name - "VBAProject"
You can use Public variables in Add-ins
Now save the file as .XLA (2003 version) or .xlam (2007 version) [ Note you can save the file in any location - just remember where you have saved the addin file)
Now your Addin has been created

So now the addin has been created, how to include the same in your project -

Now goto the main Excel file where you have to include the addin and goto the Visual Basic Editor (press Alt-F11)

Go to Tools > References > Click on Browse and select the required .xla or .xlam file

At this stage if you are getting any errors the below are the possible reasons -

The Function Name or Module name or Project name or Sub routine name or Variable name would have already been there in the current module as well. Check for duplicated Sub or Function or Variable name and correct it
If the current Excel file already has an Addin and you get an error while including a new Addin the check for the same issues - Function Name, Sub routine Name, Project Name, Variable names etc

Now that you have included the Addin, how to make it working -

In the current Excel sheet - goto the Visual Basic Window and double click on "ThisWorkbook" and enter the below code -

'''' Below Code Courtesy http://www.brainbell.com/tutorials/ms-office/excel/Distribute_Macros.htm

Option Explicit

Dim cControl As CommandBarButton

Private Sub Workbook_AddinInstall()

On Error Resume Next

Call AddMenus

On Error GoTo 0

End Sub

Private Sub Workbook_AddinUninstall()

On Error Resume Next 'In case it has already gone.

Call DeleteMenu

On Error GoTo 0

End Sub

Sub AddMenus()

Dim cMenu1 As CommandBarControl

Dim cbMainMenuBar As CommandBar

Dim iHelpMenu As Integer

Dim cbcCutomMenu As CommandBarControl

'========= use the below code to create Addin Drop down button

'(1)Delete any existing one. We must use On Error Resume next _

'in case it does not exist.

On Error Resume Next

Application.CommandBars("Worksheet Menu Bar").Controls("&Drop down Name").Delete

'(2)Set a CommandBar variable to the worksheet menu bar

Set cbMainMenuBar = _

Application.CommandBars("Worksheet Menu Bar")

'(3)Return the index number of the Help menu. We can then use _

this to place a custom menu before it.

iHelpMenu = _

cbMainMenuBar.Controls("Help").Index

'(4)Add a control to the "Worksheet Menu Bar" before Help.

'Set a CommandBarControl variable to it

Set cbcCutomMenu = _

cbMainMenuBar.Controls.Add(Type:=msoControlPopup, _

Before:=iHelpMenu)

'(5)Give the control a caption

cbcCutomMenu.Caption = "&Drop down Name"

'(6)Working with our new control, add a sub control and _

' give it a caption and tell it which macro to run (OnAction).

With cbcCutomMenu.Controls.Add(Type:=msoControlButton)

.Caption = "DD List 1"

.OnAction = "DD list1_macro" ''' this macro name should be the same in the addin

End With

'(6a)Add another sub control and give it a caption _

'and tell it which macro to run (OnAction)

With cbcCutomMenu.Controls.Add(Type:=msoControlButton)

.Caption = "DD List 2"

.OnAction = "DD List2_macro" ''' this macro name should be the same in the Addin

End With

'Repeat step "6a" for each menu item you want to add.

'Add another menu that will lead off to another menu

'Set a CommandBarControl variable to it

'======== use the below code just to create just one addin button

' Set cbcCutomMenu = cbcCutomMenu.Controls.Add(Type:=msoControlPopup)

' Give the control a caption

' cbcCutomMenu.Caption = "Ne&xt Menu"

'Add a control to the sub menu just created above

' With cbcCutomMenu.Controls.Add(Type:=msoControlButton)

' .Caption = "&Charts"

' .FaceId = 420

' .OnAction = "MyMacro2"

' End With

On Error GoTo 0

End Sub

Sub DeleteMenu()

On Error Resume Next

Application.CommandBars("Worksheet Menu Bar").Controls("&Drop down Name").Delete

Application.CommandBars("Worksheet Menu Bar").Controls("DD List 1").Delete

Application.CommandBars("Worksheet Menu Bar").Controls("DD List 2").Delete

On Error GoTo 0

End Sub

Now that the code is ready how to execute it !!

Create a Console Sheet and Add Two Command Buttons-

1st Button - Name "Delete Addin" - Call the macro "DeleteMenu()"

2nd Button - Name "Include Addin" - Call the macro "AddMenus()"

Procedure to use the Addin

When you first click on Include Addin Button, Excel would create a Drop down / buttons in Addin Tab

When you click on Delete Addin Button, Excel would remove the Drop down / buttons in Addin Tab

So that you have created Addin, Include the Addin, and created buttons in Addin - how to execute the Addin

Its just simple now, you just got to click on the buttons created in the Addin Tab to run the appropriate macro

Voila… it works !!!

Customized Mail Merge - Excel VBA

2010-12-11T19:48:00.000+05:30

Excel Macro - Mail Merge

Ever wondered how to send multiple attachments to a set of 'To' list and 'CC' list with different Mail body text !!

Well here is the solution to send email attachments with customized To, CC & Mail Body text

Open an Excel Sheet and enter the Attachment details in Col B [path and file name]; To list in Col C [if there are multiple email ids then separate them with Semi-Colon ';'] ; Mail Body contents in Col D

The line which says .send if activated, all mails would be sent automatically.

Function Email_Attachment()

Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim WBMl As Workbook

Set WBMl = ActiveWorkbook
R = WBMl.Sheets(1).Range("B65536").End(xlUp).Row
S = WBMl.Sheets(1).Range("B1").End(xlDown).Row

For a = S To R
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
        .To = Cells(a, 3).Text
        .CC = Cells(a, 4).Text
        '.SentOnBehalfOfName = """xyz"" "
        .Subject = "Resources"
        .Body = Cells(a, 5).Text
        .Attachments.Add Cells(a, 2).Text

' un-comment the below option to send mails automatically
'.send

        ' the below option is give so that the mails are draft mode.
        .display
    End With
    Set olMail = Nothing
    Set olApp = Nothing
Next a
End Function

Error Handling - Find Method

2010-12-05T23:50:00.000+05:30

How to handle an error when the value which you are searching is not available in Excel sheet.

Sub Err_Hnd()

Dim M_Rng as Range
Sheets("My Sheet").Select
On Error Resume Next
Set M_Rng = Sheets("My Sheet").Columns(1).Find(What:=Test_PID, after:=Cells(1, 1), LookIn:=xlValues,
                    LookAt:=xlPart, SearchOrder:=xlByRows, _
                    searchdirection:=xlNext, MatchCase:=False)
On Error GoTo 0

If M_Rng Is Nothing Then GoTo Err_H:
'''' if M_Rng has returned any value then your code execution starts from here
Err_H:
           '''' based on the error what has to be done
           ''' exit sub
End Sub

Below are the Error Handler Options in Excel VBA-

On Error GoTo
Enables the error-handling routine that starts at , which is any line label or line number. The specified line must be in the same procedure as the On Error statement.
On Error Resume Next
Specifies that when a run-time error occurs, control goes to the statement immediately following the statement where the error occurred. In other words, execution continues.
On Error GoTo 0
Disables any enabled error handler in the current procedure.

In the above example what we are doing is allowing the execution of the macro to proceed if an error occurs (i.e, using the On Error Resume Next )
Subsequently we are disabled the error handler using On Error GoTo 0
Now we are checking the Range variable if it contains Nothing, if yes then we take the code execution to the error handler label, otherwise the execution proceeds as usual.

Using Find Method in Code

2010-12-05T23:33:00.001+05:30

Sometimes in Excel Macro coding, when you are required to find any specific cell value and execute the list of codes. It becomes extremely time taking when you loop through all cells in the excel column.The simple solution is to use the Find method in Excel Code.

Set rFound_Cell=Columns(2).Find(What:="$$", after:=Cells(1,1), LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, _
    searchdirection:=xlNext, MatchCase:=False)

SRow=rFound_Cell.Row

What if there are multiple matching cells and you got to loop through each time the match occurs -
Use the Countif Function to establish the number of occurrence of string or value in the sheet and then loop it.

Dim rFound_Cell As Range
Set rFound_Cell = Range("B1")
Sheets("Sheet1").Select
For i = 1 To WorksheetFunction.CountIf(Columns(2), "($$$)")

      Set rFound_Cell = Columns(2).Find(What:="($$$)", after:=rFound_Cell, LookIn:=xlValues, _
                                    LookAt:=xlPart, SearchOrder:=xlByRows, _
                                    searchdirection:=xlNext, MatchCase:=False)
      SRow = rFound_Cell.Row

Next i

How to Speed-up the macro execution

2010-12-05T22:51:00.000+05:30

Sub Main_Prg()
Speedup_Macro True
'''' Your Code
'''
'''end of code
Speedup_Macro False
End Sub

Function Speedup_Macro(Chk As Boolean)
If Chk = True Then
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "Macro is working....pls wait "
Else
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.StatusBar = ""
End If
End Function

Description -
Application.DisplayAlerts

The default value is True. Set this property to False if you don't want to be disturbed by prompts and alert messages while a macro is running; any time a message requires a response, Microsoft Excel chooses the default response.
When using the SaveAs method for workbooks to overwrite an existing file, the 'Overwrite' alert has a default of 'No', while the 'Yes' response is selected by Excel when the DisplayAlerts property is set equal to False.

Application.ScreenUpdating
Turn screen updating off to speed up your macro code. You won't be able to see what the macro is doing, but it will run faster.
Remember to set the ScreenUpdating property back to True when your macro ends.

Procedure to reduce the size of Excel files

2010-09-12T00:39:00.002+05:30

Just wondering how to reduce the size of Excel files, frustrated with ever increasing excel file size without any idea, tried creating new copies still of no use. Well even I was a victim of this ever increasing file size in excel. After a lot of trial and error method and some technical analysis, I tried to put the steps in order so that it would be helpful for everyone.

Follow the below steps to reduce the size of excel files -

Before starting the procedure take a backup of the file
Unhide all sheets
Select all unused / blank columns and go to Edit>Clear>All
Select all unused / blank rows and go to Edit>Clear>All
Repeat the steps 2 & 3 for all the sheets
Save the file and close it and now check the file size, it would have reduce considerably.

The above steps work, believe me I have tested the same and after following the steps the file size reduced from 90 MB straight down to 5 MB !!!

Also some excel sheets would have a very small scroll bar irrespective of the contents of the sheet

Steps to correct the scrollbar issue –

Find the last used row and then select all the cells below this till end of the column

Select Edit > Delete and select Entire Row

Now Save the excel file and then reopen it

Now the scrollbar would turn out to be of normal length

Hope this works and the file size would be reduced thereby saving time to open the file and also save the disk space.

Thanks for reading this article J

Excel Functions Library

2010-06-26T01:44:00.000+05:30

Excel Functions Library

Good Website to understand basics of Excel Macro - 2

2010-06-26T01:38:00.000+05:30

http://www.tushar-mehta.com/excel/vba/beyond_the_macro_recorder/

Autofilter error - Autofilter Method of Range class failed

2010-06-26T01:22:00.000+05:30

How to handle error in AutoFilter Method while using Excel Macros -

Error - "autofilter method of range class failed"

Reasons -

because the rows might be blank

It's caused because your data is not laid out for AutoFilter. To use AutoFilter the data has to be in a table layout with a Header, with no empty rows or columns.

Solution-

select the complete range of values and then do selection.autofilter

How to Subtract the given no.of days from today

2010-06-26T01:18:00.000+05:30

Sub Sub_dates()

x = InputBox("Enter the no.of days to be subtracted from today's date")
y = DateAdd("d", -x, Now)
z = Mid(y, 1, InStr(1, y, " ") - 1)

MsgBox z
End Sub

How to rename file in a directory

2010-06-26T01:15:00.000+05:30

Sub rename_file()

Dim OldName, NewName

clearfilepath

SearchFile

Sheets("FilePath").Select

Range("A65536").Select

ro1 = Selection.End(xlUp).Row

For i = 2 To ro1

OldName = Cells(i, 1).Value '"D:\Documents and Settings\XXXXXX\Devlopment\2010-3-30\chr0101.591"

NewName = OldName & ".csv" ' Define file names.

Name OldName As NewName ' Rename file.

Next i

MsgBox "Its done !!"

End Sub

Function SearchFile()

Set fs = Application.FileSearch

With fs

'‘this code automatically searches for files in desktop – Source File folder

.LookIn = Environ("userprofile") & Application.PathSeparator & "Desktop" & Application.PathSeparator & "Source File" & Application.PathSeparator

.FileType = msoFileTypeAllFiles

If .Execute > 0 Then

Sheets("FilePath").Select

For i = 1 To .FoundFiles.Count

Range("A" & (i + 1)).Value = .FoundFiles(i)

Next i

Else

'MsgBox "There were no Binder files found."

End If

End With

End Function

Function clearfilepath()

Sheets("FilePath").Select

Range("A2:A65536").Select

Selection.ClearContents

End Function

Good Website to understand basics of Excel Macro

2010-06-26T01:12:00.002+05:30

I just came across this website and seems to be really good to understand macro from basics.

http://www.anthony-vba.kefra.com/vba/vbabasic1.htm

Draw border lines around cells with common values

2010-06-26T01:11:00.002+05:30

How to draw borders around cells with common values

Sub Draw_border_for_common_items_in_row()

Sheets("Top CTDs").Select

LC1 = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column

LR1 = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row

For i = 1 To LC1

temp = Cells(2, i).Value

ro = 2

For j = 2 To LR1

If Cells(j, i).Value <> temp Then

Range(Cells(ro, i), Cells(j - 1, i)).Select

Selection.BorderAround Weight:=xlThin

ro = j

temp = Cells(j, i).Value

End If

Next j

Next i

End Sub

Collating the CMS Avaya Raw Dump into consolidated raw data

2010-06-26T01:09:00.000+05:30

Sub test()
Dim myDir As String, fn As String
myDir = "W:\XXXXXXXXXX\2010\Raw dump - avaya script\"
fn = Dir(myDir & "*.xls")
Do While fn <> ""
    If fn <> ThisWorkbook.Name Then
        With Workbooks.Open(myDir & fn)
            With .Sheets(1).Range("A1:IV200")
                ThisWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp)(4) _
                .Resize(.Rows.Count, .Columns.Count).Value = .Value
            End With
            .Close False
        End With
    End If
    fn = Dir
Loop
Rows("1:3").Select
Selection.Delete shift:=xlUp
Range("a1").Select
End Sub

How to edit CMS Avaya Script

2010-06-26T01:06:00.000+05:30

Open the required CMS Avaya Script and Save the Script and then do the below modifications -

comment the line

b=Rep.Run

and add the below line

b=Rep.Exportdata("\\path\Raw dump - avaya script\255.xls",9,0,false,true,true)

also if you wanna make the script more dynamic then add the below lines

Date1 = Inputbox ("Please enter the Start date of the reports you wish to see in the format mm/dd/yyyy")

Time1 = Inputbox ("Please enter the Start Time of the reports you wish to see in the format hh:mm")

Date2 = Inputbox ("Please enter the END date of the reports you wish to see in the format mm/dd/yyyy")

Time2 = Inputbox ("Please enter the END Time of the reports you wish to see in the format hh:mm")

and now modify the Rep property section as shown below -

Rep.SetProperty "Splits/Skills","255" 'Skill number

Rep.SetProperty "Start Date",Date1 '-1 - Yday

Rep.SetProperty "Start Time",Time1 '"14:30" - start time

Rep.SetProperty "Stop Date",Date2 '0 -today

Rep.SetProperty "Stop Time",Time2 '04:00 - end time

Finding the last row or column

2010-06-26T00:59:00.003+05:30

How to find the last row or last column in any excel sheet

LR = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row

LC = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column

LR= range("A65536").end(xlup).row

Lc=range("IV1").end(xltoleft).column

Excel Macro Man: How to rename file in a directory

2010-04-04T00:17:00.002+05:30

Excel Macro

Sub rename_file()

Dim OldName, NewName

clearfilepath

SearchFile

Sheets("FilePath").Select

Range("A65536").Select

ro1 = Selection.End(xlUp).Row

For i = 2 To ro1

OldName = Cells(i, 1).Value '"D:\Documents and Settings\xxxx\Desktop\2010-3-30\chr0101.591"

NewName = OldName & ".csv" ' Define file names.

Name OldName As NewName ' Rename file.

Next i

MsgBox "Its done !!"

End Sub

Function SearchFile()

Set fs = Application.FileSearch

With fs

'‘this code automatically searches for files in desktop – Source File folder

.LookIn = Environ("userprofile") & Application.PathSeparator & "Desktop" & Application.PathSeparator & "Source File" & Application.PathSeparator

.FileType = msoFileTypeAllFiles

If .Execute > 0 Then

Sheets("FilePath").Select

For i = 1 To .FoundFiles.Count

Range("A" & (i + 1)).Value = .FoundFiles(i)

Next i

Else

'MsgBox "There were no Binder files found."

End If

End With

End Function

Function clearfilepath()

Sheets("FilePath").Select

Range("A2:A65536").Select

Selection.ClearContents

End Function

Subtract the given no.of days from today

2010-04-04T00:01:00.001+05:30

Enter the no.of days to be subtracted from today

for eg:- if Now returns 3rd April 2010

and you enter 3 ... then it would return 31st March 2010

Sub Sub_dates()

x = InputBox("Enter the no.of days to be subtracted frm today")
y = DateAdd("d", -x, Now)
z = Mid(y, 1, InStr(1, y, " ") - 1)

MsgBox z
End Sub

How to rename file in a directory

2010-04-03T23:58:00.000+05:30

Sub rename_file()

Dim OldName, NewName

clearfilepath

SearchFile

Sheets("FilePath").Select

Range("A65536").Select

ro1 = Selection.End(xlUp).Row

For i = 2 To ro1

OldName = Cells(i, 1).Value '"D:\Documents and Settings\xxxxxxxxx\Desktop\2010-3-30\chr0101.591"

NewName = OldName & ".csv" ' Define file names.

Name OldName As NewName ' Rename file.

Next i

MsgBox "Its done !!"

End Sub

Function SearchFile()

Set fs = Application.FileSearch

With fs

'‘this code automatically searches for files in desktop – Source File folder

.LookIn = Environ("userprofile") & Application.PathSeparator & "Desktop" & Application.PathSeparator & "Source File" & Application.PathSeparator

.FileType = msoFileTypeAllFiles

If .Execute > 0 Then

Sheets("FilePath").Select

For i = 1 To .FoundFiles.Count

Range("A" & (i + 1)).Value = .FoundFiles(i)

Next i

Else

'MsgBox "There were no Binder files found."

End If

End With

End Function

Function clearfilepath()

Sheets("FilePath").Select

Range("A2:A65536").Select

Selection.ClearContents

End Function

Draw Border for the common cell values

2010-03-30T23:47:00.000+05:30

Sub Draw_border_for_common_items_in_row()

Sheets("Sheet1").Select

LC1 = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column

LR1 = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row

For i = 1 To LC1

temp = Cells(2, i).Value

ro = 2

For j = 2 To LR1

If Cells(j, i).Value <> temp Then

Range(Cells(ro, i), Cells(j - 1, i)).Select

Selection.BorderAround Weight:=xlThin

ro = j

temp = Cells(j, i).Value

End If

Next j

Next i

End Sub

How to Sum the Visible cells data from the filtered range

2010-03-30T01:29:00.000+05:30

Here is the solution to sum the visible cells data from the given range ... :-)

Function Sum_Visible_Cells(ByRef Cells_To_Sum As String)

Application.Volatile
Range(Cells_To_Sum).SpecialCells(xlCellTypeVisible).Select
Sum_Visible_Cells = WorksheetFunction.Sum(Selection)

End Function

How to clean the leading or trailing cell spaces in a given range

2010-03-30T01:23:00.002+05:30

Using this function you can now clean the leading or trailing spaces in the cell range

Function Clean_cells_in_range(ByRef Cells_to_Clean As String)

    For Each cell In ActiveSheet.Cells.Range(Cells_to_Clean)
        cell.Value = Trim(cell)
    Next cell

End Function

Subtract the given no.of days from today

2010-03-30T01:20:00.000+05:30

There might be some instances where you would require to subtract the give number of days from today.... so here is the solution.

No need to worry about the month rollback or year rollback... excel would take care of this automatically

Function Subtract_Date_from_Today(ByRef noofdays As Integer)
    result = Now() - noofdays
    Dt = Day(result)
    Mo = Month(result)
    Yr = Right(Year(result), 2)
    If Len(Mo) = 1 Then Mo = "0" & Mo
    If Len(Dt) = 1 Then Dt = "0" & Dt
    Subtract_Date_from_Today = Mo & Dt & Yr
End Function

How to compare dates in Excel Macro

2010-03-30T01:18:00.000+05:30

Well this is quite simple.... if you have a cell value as 3/28/10 (m/dd/yy)... which is 3rd March 2010 and you need to compare this with the data 28/03/2010 ... which is in dd/mm/yyyy format

All you need to do is to convert the data in the required format to match

compare_Dt = Format(DateSerial(Yr, Mo, Dt), "mm/dd/yyyy")

For j = rng1 to rng2

Source= Format(Cells(3, j).Value, "mm/dd/yyyy")

If Source = compare_Dt Then

your code when the date matches

Exit For

End If

How to convert Column Number to Name

2010-03-30T01:12:00.000+05:30

Using the below function you can now convert the column number to name
...for eg.. if the col no is 26 then this function would return "Z" as column name

Function Convert_Column()
    Dim MyColumn As String, Here As String

    ' Get the address of the active cell in the current selection
    Here = ActiveCell.Address

    ' Because .Address is $$, drop the first
    ' character and the characters after the column letter(s).
    Convert_Column = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
End Function