Sunday, September 27, 2009

Excel Macros : Log User Activity to Log Sheet

We all store Excel workbooks on shared drives. While those files are accessed by many users but there is no track about who did what at various points of time. However this problem can be resolved with the help of VBA. A VBA programme with following capability can help us to get the log of user activity.
 
1. Add sheet named Log in case it is does not exist in the file.
2. Record user activity based on events to Log sheet.
3. Along with recording a event, it records user information and time of event.
4. Manage log size and removes old entries while creating space for new entries.
5. User can view the log but can not make changes to the log.


Following code has all these capabilities. Macro given below records user activity based on event information passed to it by another macro. You will need to copy this code to regular VBA module of your workbook

Sub Elog(Evnt As String)

'***************************************************************************************************
'* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 27, 2009 *
'***************************************************************************************************

Application.ScreenUpdating = False
Dim cRecord As Long
cSheet = ActiveSheet.Name

If SheetExists("Log") = False Then
Sheets.Add.Name = "Log"
Sheets("Log").Select
ActiveSheet.Protect "Pswd", UserInterfaceOnly:=True
End If

Sheets("Log").Visible = True
Sheets("Log").Select
ActiveSheet.Protect "Pswd", UserInterfaceOnly:=True

cRecord = Range("A1")
If cRecord <= 2 Then
cRecord = 3
Range("A2").Value = "Event"
Range("B2").Value = "User Name"
Range("C2").Value = "Domain"
Range("D2").Value = "Computer"
Range("E2").Value = "Date and Time"
End If

If Len(Evnt) < 25 Then Evnt = Application.Rept(" ", 25 - Len(Evnt)) & Evnt

Range("A" & cRecord).Value = Evnt
Range("B" & cRecord).Value = Environ("UserName")
Range("C" & cRecord).Value = Environ("USERDOMAIN")
Range("D" & cRecord).Value = Environ("COMPUTERNAME")
Range("E" & cRecord).Value = Now()
cRecord = cRecord + 1

If cRecord > 20002 Then
Range("A3:A5002").Select
dRows = Selection.Rows.Count
Selection.EntireRow.Delete
cRecord = cRecord - dRows
End If

Range("A1") = cRecord
Columns.AutoFit
Sheets(cSheet).Select
Sheets("Log").Visible = xlVeryHidden
Application.ScreenUpdating = True

End Sub
Function SheetExists(SheetName As String) As Boolean
On Error GoTo SheetDoesnotExit
If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If
SheetDoesnotExit:
SheetExists = False
End Function
Sub ViewLog()
Sheets("Log").Visible = True
Sheets("Log").Select
End Sub
Sub HideLog()
Sheets("Log").Visible = xlVeryHidden
End Sub


Following macros record events like

"Open" , "Save" and "Print"

and pass on the information to above macro to record user activity.

You will need to copy this code to worksheet module of your workbook


Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim Evnt As String
Evnt = "Print"
Call Elog(Evnt)
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Evnt As String
Evnt = "Save"
Call Elog(Evnt)
End Sub

Private Sub Workbook_Open()
Dim Evnt As String
Evnt = "Open"
Call Elog(Evnt)
End Sub


Since this code will record user activity only in case macros are enabled, do not forget to force users to enable macros while useing the particular file.

Download file having these macros to record user activity to a log sheet. Check how it works



record user activity , track user activity, logging user activity, log user activity , monitor user activity

Tuesday, September 22, 2009

Excel Macros : Check Mark Symbols with Double Click


I am sharing with you very interesting trick to insert check mark symbols / to change check mark symbols with the double click in excel.

We can use Wingding font check boxes and change them with the double click with the help of macro

You can add as many of them by just defining the range in your macro. Values can be changed by just a double click.

You will further need to do data validation for that range so that user does not enter any other value by mistake.

You will need to copy this code to worksheet module of your workbook


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'*************************************************************************************************************************
'* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 16, 2009 *
'*************************************************************************************************************************

If Not Intersect(Target, Range("G4:G14")) Is Nothing Then ' You can Change the range here

Cancel = True

With Target
.Font.Name = "Wingdings"
.Font.Size = 20
.HorizontalAlignment = xlCenter
End With

If Target.Value = "þ" Then
Target.Value = "ý"

Else
Target.Value = "þ"
End If

End If

End Sub

Download file having trick to insert /change wingdings check mark symbols with double click



Make sure that you have enabled macros before using this file.

This trick can be used to choose any values you want change with the double click and is not limited only to check boxes in wingdings. See the attached file for Yes/No as another example.

Symbol Check Mark , Symbols Check Mark , Type Check Mark , Wingding Font Check Mark , Wingding Check Mark , Wingdings Check Mark , Check Mark Symbol , Check Mark Symbols , Check Symbol , Change values with double click in excel

Wednesday, September 16, 2009

Excel Macro : File open VBA

Before opening a excel file using VBA, you need to test particular file is open or not in excel. This is required as it can result into a error if particular file is already open.

You need to go step by step to open the file 
1. Check if excel file is open
2. Open that file using VBA , This should be done only in case you know the full path for the particular file
3. In case you do not know the full path , it is advisable to give excel file open dialog and let user open the file.

You will need to copy this code to regular VBA module of your workbook
Sub Open_File_after_IsOpen_or_Not()

'*************************************************************************************************************
'* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 16, 2009 *
'* Macro modified on September 19, 2009 based on inputs from Mr. Augusto as per comment left by him *
'* Mr. Augusto added FileExist function though his comment and included in this Updated Macro by Yogesh Gupta*
'*************************************************************************************************************

Dim Myworkbook As String

Myworkbook = "FileName.xls" ' Replace the workbook name here

If Isopen(Myworkbook) = "Not Open" Then ' In case workbook is not open

If FileExist(Myworkbook) = True Then ' In case workbook exist

Workbooks.Open Filename:=ThisWorkbook.Path & "\" & Myworkbook

Else

Call Open_new_file ' let user choose and open the file

End If

Else

Application.Workbooks(Myworkbook).Activate

End If

End Sub

Sub Open_new_file()

NewWorkbook = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file")
If NewWorkbook = False Then
Exit Sub
Else
Workbooks.Open Filename:=NewWorkbook
End If

End Sub

Public Function Isopen(Myworkbook As String)

On Error Resume Next
Set wBook = Workbooks(Myworkbook)
If wBook Is Nothing Then
Isopen = "Not Open"
Exit Function
End If

End Function
Public Function FileExist(Myworkbook As String) As Boolean

Dim nfile

On Error GoTo FileExist_err
nfile = FreeFile
Open Myworkbook For Input As nfile
Close nfile

FileExist = True

Exit Function
FileExist_err:
FileExist = False
End Function

Download file having File open Macro with test if particular workbook is open or not



File open VBA , VBA open files , File Open Macro , Excel File open VBA , VBA Excel Workbook Open , VBA Excel Open Workbook , VBA open Workbook , Test particular file is open or not in excel , Check if file is open - Excel

Wednesday, September 9, 2009

Excel Macros : Remove Duplicates Excel

Excel 2007 has built in command to remove duplicates, however earlier versions of excel does not have built in command. You need to use VBA routine to do the job.

Use following code to Identify duplicate values in a column and Remove Rows having Duplicate Values

After identifying the duplicate values system will give you warning and ask for confirmation to delete the entire row(s) having duplicate values. You can choose No in case you do not want to delete them.

You will need to copy this code to regular VBA module of your workbook

Sub Find_RemoveDuplicates()

'****************************************************************************************************
'* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 9, 2009 *
'* Macro Modified on September 13, 2009 for not deleting empty cells within duplicate values column *
'****************************************************************************************************


Dim cRow As Long
Dim lRow As Long
Dim sCell As Range
Dim D As Long

lRow = GetLastRowWithData

On Error Resume Next
Set sCell = Application.InputBox(Prompt:= _
"Select Starting Row of Column with Duplicate values.", _
Title:="Select Column", Type:=8)

On Error GoTo 0
If sCell Is Nothing Then
Exit Sub
End If

sCell.Select

If Selection.Cells.Count > 1 Then
MsgBox ("Pls select Single Cell only")
Exit Sub

Else

dCol = ActiveCell.Column
sRow = ActiveCell.Row

For cRow = lRow To sRow Step -1
If IsEmpty(Cells(cRow, dCol)) = False Then
If WorksheetFunction.CountIf(Range(sCell, Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then
Cells(cRow, dCol).Interior.Color = 255 'This Marks the duplicate values as Red
D = D + 1
End If
End If
Next cRow

If D = 0 Then

MsgBox ("No Duplicate Values Found")

Else

caution = MsgBox(D & " Duplicate entries selected and marked RED" & vbCrLf & _
"Do you want to delete them? " & vbCrLf & _
"Entire Row for the marked entries will be deleted. " & vbCrLf & _
"Do you want to Continue?", vbYesNo, "Confirmation")

If caution = vbYes Then

For cRow = lRow To sRow Step -1
If IsEmpty(Cells(cRow, dCol)) = False Then
If WorksheetFunction.CountIf(Range(sCell, Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then
Cells(cRow, dCol).EntireRow.Delete ' This deletes the entire row
End If
End If
Next cRow

End If
End If
End If

End Sub

'********************************************************************
'* UDF to Get Last Row with Data on worksheet *
'********************************************************************

Public Function GetLastRowWithData() As Long

Dim ExcelLastCell As Object, lRow As Long, lLastDataRow As Long, l As Long

Set ExcelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
lLastDataRow = ExcelLastCell.Row
lRow = ExcelLastCell.Row

Do While Application.CountA(ActiveSheet.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop

lLastDataRow = lRow
GetLastRowWithData = lLastDataRow

End Function

Download file having Macro to Find and Remove Duplicates in Excel.



Above works well in case you are trying to clean a data table on the sheet, however if you have lots of other data also on the sheet, you should try the Find and Remove duplicates within Range

RemoveDuplicates

You will need to copy this code to regular VBA module of your workbook

Sub Find_RemoveDuplicatesWithinRange()

'***************************************************************************************************
'* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 13, 2009 *
'***************************************************************************************************

Dim cRow As Long
Dim sRow As Long
Dim lRow As Long
Dim sCol As Long
Dim lCol As Long
Dim dColumn As Long
Dim D As Long
Dim sCell As Range
Dim dRange As Range


On Error Resume Next

Set dRange = Application.InputBox(Prompt:= _
"Select Data Range with Duplicate values.", _
Default:=Selection.Address, Title:="Select Range", Type:=8)

If dRange Is Nothing Then
Exit Sub
End If

With dRange
sRow = Cells(.Row, .Column).Row
sCol = Cells(.Row, .Column).Column
lCol = Cells(.Row, .Column + .Columns.Count - 1).Column
lRow = Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1).Row
End With

dColumn = 0

Do While dColumn = 0

Set sCell = Application.InputBox(Prompt:= _
"Select Column with Duplicate values.", _
Title:="Select Column", Type:=8)

On Error GoTo 0

If sCell Is Nothing Then
Exit Sub
End If


If sCell.Columns.Count > 1 Then

MsgBox ("Pls select Single Column only")

Else

dCol = sCell.Column
If dCol < sCol Then
MsgBox ("Select Column within earlier Range")
ElseIf dCol > lCol Then
MsgBox ("Select Column within earlier Range")
Else
dColumn = 1
End If

End If

Loop

For cRow = lRow To sRow Step -1
If IsEmpty(Cells(cRow, dCol)) = False Then
If WorksheetFunction.CountIf(Range(Cells(sRow, dCol), Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then
Range(Cells(cRow, sCol), Cells(cRow, lCol)).Select
Selection.Interior.Color = 255
D = D + 1
End If
End If
Next cRow

Cells(sRow, sCol).Select

If D = 0 Then

MsgBox ("No Duplicate Values Found")

Else

caution = MsgBox(D & " Duplicate entries selected and marked RED" & vbCrLf & _
"Do you want to delete them? " & vbCrLf & _
"Marked entries will be deleted and data will move up " & vbCrLf & _
"Do you want to Continue?", vbYesNo, "Confirmation")

If caution = vbYes Then

For cRow = lRow To sRow Step -1
If IsEmpty(Cells(cRow, dCol)) = False Then
If WorksheetFunction.CountIf(Range(Cells(sRow, dCol), Cells(cRow, dCol)), Cells(cRow, dCol).Text) > 1 Then
Range(Cells(cRow, sCol), Cells(cRow, lCol)).Select
Selection.Delete Shift:=xlUp
End If
End If
Next cRow
Cells(sRow, sCol).Select
End If
End If

End Sub

Download file having macro to find and remove duplicates within a range



Delete Duplicates , Delete Duplicate , Remove Duplicates , Remove Duplicate , Find Duplicates , Find Duplicate , Excel Delete Duplicates , Remove Duplicates Excel , Remove Duplicate Excel

Friday, September 4, 2009

Excel Macros : Find Last Row

Many times we need to find out the last row of excel sheet which is used by data. This has many uses such as to
Add new column to the data only up to the last used row of exiting dateAdd new row to the data immediately after the last row so as you do not over write the exiting data.
See the code below for the doing the activities as listed above.
Sub LastRowOfData()

'***************************************************************************************************
'* Macro recorded by Yogesh Gupta, smiley123z@gmail.com, Ygblogs.blogspot.com on September 4, 2009 *
'***************************************************************************************************


If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.AutoFilterMode = False
End If
LastRow = GetLastRowWithData ' Getting the Row number

Range("C3").Select ' Select the header row of the data in new column
ActiveCell.FormulaR1C1 = "Col 2" ' Add new column header
Range("C4").Select ' Select the starting column where you need to add data
ActiveCell.FormulaR1C1 = "XYZ" ' Add Data Value or Formula
Range("C4:C" & LastRow).Select ' This will select the column from starting row to Last row of data
Selection.FillDown ' This will fill the data downwards from First row i.e. Formula or value added by you

Range("B" & LastRow + 1).Select ' This selects the starting cell of row next to last row of exiting data


End Sub

'********************************************************************
'* UDF to Get Last Row with Data on worksheet *
'********************************************************************
Public Function GetLastRowWithData() As Long

Dim ExcelLastCell As Object, lRow As Long, lLastDataRow As Long, l As Long

Set ExcelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
lLastDataRow = ExcelLastCell.Row
lRow = ExcelLastCell.Row
'
Do While Application.CountA(ActiveSheet.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop
'
lLastDataRow = lRow

GetLastRowWithData = lLastDataRow

End Function

Function GetLastRowWithData gives inaccurate results if you have active filters on the worksheet. That is why I have included code to remove active filters from the worksheet before using this function to get last row of data.

Download sample file to check how it works.

There is one more option which gives you satisfactory results

LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Take care to remove filters before using above code

There are some more options to find last row however are not very reliable as they give you last row of the worksheet irrespective of fact that row could be a empty row.

LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
or
LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

Select Last Row , Find Last Row , VBA Last Row , VBA Find Last Row , Excel Last Row