Posts Tagged ‘Macro’


Problem Statement: I have a database of employees where I store information about each person. I wish to have a picture of the employee in my database that I want to retrieve when I select an employee ID. Solution: I am sharing a VBA code that saves the file in SQL server table in binary format. When the file is retrieved, it can be done in original format. Let’s say I’ve a table Employee, it has two columns ID (Datatype: int) and Image (Datatype: varBinary(Max)). Code to store an image as binary type: (more…)

Advertisements

When an error occurs in your VBA project then it is extremely valuable to know what caused it so that you know how to counter it. Erl function returns the line number where an error occurs. For using this, your lines of code should be numbered (The line numbers don’t have to be in any order, you can assign random numbers to the lines of code). If the line of code where the error occurred is not numbered then it will return the line number which has been numbered before this. If none of the lines are numbered then it will return 0.


Sub Test_Erl()        
    Dim lngval          As Long    
    On Error GoTo ErrHandler     
1   Debug.Print "Error handler enabled"
2   lngval = 2 / 0        
ErrHandler:
    MsgBox "An error occured in line: " & Erl    
End Sub

(more…)


When we press [Alt] + [F8], a macro explorer window is displayed, which lists all available macros (Public) in the current project even if the project is password protected. In this window, we can select any macro and can run/execute it. That might be undesirable sometimes.

Using Option Private Module at the top of a module prevents all macros of that module from being displayed in the macro list.

e.g.
   

  Option Private Module
      Sub Test1()
            '//
      End Sub
      Sub Test2()
            '//
      End Sub

In the above example, procedures Test1 and Test2 will not be displayed in the macro explorer window because Option Private Module is written at the top of the module.

Basic use of  Option Private Module is to prevent macros and variables from being accessed by outside of the current projects. For more details http://msdn.microsoft.com/en-us/library/aa266185(v=vs.60).aspx


We send so many mails everyday that sometimes we forget to attach files or add subject line. Here we have a macro that solves both the issues.It prompts the user if:

  1. subject line is missing or
  2. there are words like enclosedattached and PFA in message body but attachment is missing

To add this macro in your outlook go to Tools -> Macro -> Visual Basic Editor or just press Alt+F11 and paste the macro in ThisOutlookSession.

Subject Line or Attachment Missing_1

VBA Editor in Outlook

(more…)

Unique List Using Dictionary Object

Posted: April 30, 2013 by Transformer in Excel, VBA
Tags: , , , ,

This function is an advanced version of  Unique Values From Data Using VBA Dictionary Object .

Following are the enhancements:

1. Now the Source data can be a Range or an Array
2. User have choice to paste data whether one wants to paste it in Columns or in Rows
3.Now It can be called from the Worksheet also and will work as an Array function

It takes the following arguments:
varSource = source data from which unique values are to be extracted.It Can be a Range or an Array
blnPaste = TRUE if you want the result to be pasted to a range, FALSE by default
blnPasteHorizontally = TRUE if you want the result to be pasted in a Row , FALSE by default
rngDest = range where the results are to be pasted
blnCase = TRUE if the list is to case-sensitive, FALSE by default. The results will be in proper case for FALSE
blnCounts = TRUE if you want to see the number of occurrences of each item as well, FALSE by default


Function varUniqueList(varSource As Variant, _
                   Optional blnPaste As Boolean = False, _
                   Optional blnPasteHorizontally As Boolean = False, _
                   Optional rngDest As Range, _
                   Optional blnCase As Boolean = True, _
                   Optional blnCounts As Boolean = False)

    Dim lngLoop                 As Long
    Dim strKey                  As String
    Dim objDictionary           As Object
    Dim varSourceTemp           As Variant
    Dim blnSheetCall            As Boolean

    Application.Volatile
    On Error Resume Next
    If TypeName(Application.Caller) = "Range" Then blnSheetCall = True
    On Error GoTo 0
    If TypeName(varSource) = "Range" Then
        If varSource.Rows.Count > 1 Then
            varSourceTemp = Application.Transpose(varSource)
        Else
            varSourceTemp = Application.Transpose(Application.Transpose(varSource))
        End If
    Else
        varSourceTemp = varSource
    End If

    If Not IsArray(varSourceTemp) Then Exit Function 'Proceeding only if the array is non-empty
    Set objDictionary = CreateObject("Scripting.Dictionary")
    With objDictionary
        For lngLoop = LBound(varSourceTemp) To UBound(varSourceTemp)
            If blnCase Then
                strKey = varSourceTemp(lngLoop)
            Else
                strKey = StrConv(varSourceTemp(lngLoop), vbProperCase)
            End If
            .Item(strKey) = .Item(strKey) + 1 'Counting occurences
        Next lngLoop
        If blnCounts Then
            varSourceTemp = Application.Transpose(Array(.keys, .items))
        Else
            varSourceTemp = Application.Transpose(Array(.keys))
        End If

        If blnSheetCall = True Then blnPasteHorizontally = Not blnPasteHorizontally
        If blnPasteHorizontally = True Then
            varUniqueList = varSourceTemp
        Else
            varUniqueList = Application.Transpose(varSourceTemp)
        End If

        'Pasting results in destination range
        If blnPaste And Not rngDest Is Nothing Then
            If blnPasteHorizontally = True Then
                rngDest.Resize(1 - blnCounts, .Count).Value = Application.Transpose(varSourceTemp)
            Else
                rngDest.Resize(.Count, 1 - blnCounts).Value = varSourceTemp
            End If
        End If
    End With
    Set objDictionary = Nothing
End Function

Sometimes one might need to export data from one Excel file to another and if one wants to do so without opening any of those files (Source and destination files), then it can be done using the following procedure.

It has four parameters, last of which is optional:
1. strSourceFileFullName : Full name of the source file with extension. e.g. “C:\Challenge1.xlsx”
2. strTargetFileFullName : Full name of the target file with extension. e.g. “C:\Challenge2.xlsx”
3. strSourceSheetName : Sheet name from where data needs to be exported.
4. strTargetSheetname : Sheet name in the target file where data should be pasted. This is an optional parameter. If this parameter is not passed then a new sheet will be created with the same name as the source sheet.


Sub TransferData(strSourceFileFullName As String, _
                 strTargetFileFullName As String, _
                 strSourceSheetName As String, _
                 Optional strTargetSheetname As Variant)

    Dim adoConnection   As Object
    Dim adoRcdSource    As Object
    Dim Provider        As String
    Dim ExtProperties   As String
    Dim strFileExt      As String

    Set adoConnection = CreateObject("ADODB.Connection")
    Set adoRcdSource = CreateObject("ADODB.Recordset")
    If Len(Dir(strSourceFileFullName)) = 0 Then
        MsgBox "Input file does not exist"
        Exit Sub
    End If

    strFileExt = Mid(strTargetFileFullName, InStrRev(strTargetFileFullName, ".", -1, vbTextCompare), Len(strTargetFileFullName))

    If strFileExt = ".xlsx" Then
        ExtProperties = "Excel 12.0 XML"
    ElseIf strFileExt = ".xlsb" Then
        ExtProperties = "Excel 12.0"
    ElseIf strFileExt = ".xlsm" Then
        ExtProperties = "Excel 12.0 Macro"
    Else
        ExtProperties = "EXCEL 8.0"
    End If

    If CDbl(Application.Version) > 11 Then
      Provider = "Microsoft.ACE.OLEDB.12.0"
    Else
       Provider = "Microsoft.JET.OLEDB.4.0"
    End If

    If IsMissing(strTargetSheetname) Then
        strTargetSheetname = strSourceSheetName
    End If
    adoConnection.Open "Provider=" & Provider & ";Data Source= " & strTargetFileFullName & ";Extended Properties=""" & ExtProperties & ";HDR=YES"";"

    On Error GoTo Errorhandler
    adoRcdSource.Open "Select * into [" & strTargetSheetname & "] From [" & strSourceSheetName & "$] IN '" & strSourceFileFullName & "'[" & ExtProperties & ";HDR=YES;]", adoConnection
    adoRcdSource.Close
Errorhandler:
    If Err.Number = -2147217900 Then
        MsgBox "A sheet or a named range with the same name already exists in the target workbook. Data will not be copied.", , "Name Conflict"
    End If

    adoConnection.Close
    Set adoRcdSource = Nothing
    Set adoConnection = Nothing

End Sub

Note: If a file with the name ‘strTargetFileFullName’ is not found then it gets created automatically in the target folder but if you want to transfer data into an xlsm file than it must be there. It won’t be created automatically.
If you face any problems, email us or leave a reply.