Learn Macros‎ > ‎

VBA Macros

VBA code to import the MS Access query data into MS Excel

posted Jun 2, 2016, 9:55 AM by Ayush Jain

Sub importAccessdata(strDBPath As String, strTableName As String)

    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim sQRY As String
    Dim strFilePath As String

    strFilePath = strDBPath
    Set cnn = New ADODB.Connection
    Set rs = New ADODB.Recordset

    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & strFilePath & ";"
    sQRY = "SELECT * FROM " & strTableName

    rs.CursorLocation = adUseClient
    rs.Open sQRY, cnn, adOpenStatic, adLockReadOnly
    Application.ScreenUpdating = False
    Worksheets("Summary").Range("A2").CopyFromRecordset rs

    Set rs = Nothing
    Set cnn = Nothing
    Exit Sub

End Sub

Store excel range in an array variable

posted Nov 9, 2011, 11:06 PM by Ayush Jain   [ updated Nov 10, 2011, 12:58 AM ]

If you want to store excel range in string array variable , you can use this user define function.
Public Function ReturnArraySel(xlRange As Range) As String()
    Dim strArray() As String
    Dim intctr As Integer
    Dim intCount As Integer
    Dim xlCell As Range
    intctr = 0
    intCount = xlRange.Cells.Count
        ReDim strArray(0 To intCount - 1)
        For Each xlCell In xlRange
                strArray(intctr) = xlCell.Value
                intctr = intctr + 1
    ReturnArraySel = strArray
End Function
You just need to pass the excel range as a parameter to above function and it will return an array string.
Sub StoreArray()
    Dim strArr() As String
    strArr() = ReturnArraySel(ActiveSheet.Range("A1:A50"))
End Sub

Get Full Network Path of mapped drive

posted Jun 26, 2011, 1:11 AM by Ayush Jain

To get the full network path of mapped drive in windows, you can use the below VBA function. The function returns the full path on input of drive name like "Z:\" , "K", "T"
VBA Code: 
Function GetNetworkPath(strDrive As String)

     Dim oShell As Object, fso As Object, objFolder As Object
     Dim remPath As String

     Set oShell = CreateObject("WScript.Shell")
     On Error GoTo PathNotExist:
     remPath = oShell.RegRead("HKEY_CURRENT_USER\Network\" & Left(strDrive, 1) & "\RemotePath")

     Set fso = CreateObject("Scripting.FileSystemObject")
     If Len(strDrive) > 1 Then
       GetNetworkPath = remPath & Replace(strDrive, fso.GetDriveName(strDrive), "")
        GetNetworkPath = remPath
     End If

     Exit Function

End Function
Example :
=GetNetworkPath("Z") will give you \\\Excel\
Bouns Tip :
To map network drive in Windows, follow below steps :
1) My Computer
2) Tools --> Map Network Drive
3) Select Drive name
4) Provide Network Path
5) Finish

Calculate how long macro runs

posted Jun 19, 2011, 8:28 AM by Ayush Jain   [ updated Jun 19, 2011, 9:12 AM ]

If you want to know the duration of macro execution , You can use the below macro :

Sub TimeTaken()

    Dim strTime1 As String, strTime2 As String

    strTime1 = Format(Now(), "mm-dd-yyyy hh:MM:ss")

    '[Write your code here]

    strTime2 = Format(Now(), "mm-dd-yyyy hh:MM:ss")

    MsgBox "Elapsed Time = " & DateDiff("n", strTime1, strTime2) & _
    " Minutes and " & DateDiff("s", strTime1, strTime2) & " Seconds"

End Sub

Tags : Macro Duration, Time Difference, Time Taken in Macro execution

Column Number to Alphabetical reference

posted Mar 25, 2011, 8:07 AM by Ayush Jain   [ updated Mar 26, 2011, 7:37 AM ]

The below function can be used to convert any Column Number into Alphabets. example :- If you pass 1 to the function, it will Return A. If you pass 26, It will return Z. If you pass 27 It will return AA....and so on.

Public Function GetColumn(Pr)
    Dim Rn As Range
    Set Rn = ActiveSheet.Cells(1, Pr)
    GetColumn = Mid(Rn.Address, 2, InStr(2, Rn.Address, "$") - 2)
End Function

Let me know if you have better solution.
3/26 : Sit Vi(discussexcel member) has suggested an excel formula for the same task
=SUBSTITUTE(ADDRESS(1,16384,4),1,"") will return XFD

Add Timer to your code

posted Jan 30, 2011, 6:06 AM by Ayush Jain   [ updated Jan 30, 2011, 6:07 AM by ayushjain@live.com ]

To create a macro to measure time before executing the next line of code use this simple code.

Sub timer ()

Application.Wait Now + TimeValue("00:00:10")
MsgBox ("10 sec has elasped")

End Sub

Killing The Current File or Workbook

posted Jan 30, 2011, 5:59 AM by Ayush Jain   [ updated Jan 30, 2011, 6:04 AM by ayushjain@live.com ]

Killing the current file requires you to change it's status to read only.
Here is the code :

Sub Killed()
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
ThisWorkbook.Close False
End Sub

vbYesNo in MsgBox

posted Jan 30, 2011, 5:53 AM by Ayush Jain   [ updated Jan 30, 2011, 5:56 AM by ayushjain@live.com ]

When you want to take any action on the basis of YES or NO selected by user in MsgBox, Use this code

Public Sub YesNo()

    If MsgBox("This macro will ... Do you want to continue?", vbYesNo + vbCritical, "Caution") = vbYes Then
    ' do something
    ' do something else
    End If

End Sub

Navigation into Worksheets using Listbox

posted Jan 30, 2011, 5:24 AM by Ayush Jain   [ updated Jan 30, 2011, 5:29 AM by ayushjain@live.com ]

To navigate into your excel sheets using Listbox, You need to add a ListBox in a UserForm and copy this two simple procedures in the Userform Code:

Private Sub ListBox1_Click()
    Sheets(ListBox1.ListIndex + 1).Activate
End Sub

Private Sub UserForm_Initialize()
    Dim sht As Worksheet
    For Each sht In ActiveWorkbook.Worksheets
        ListBox1.AddItem sht.Name
    Next sht
End Sub

Once you show the UserForm it will add the names of the sheets in the ListBox, then when you click on one of the sheets name in the ListBox it will activate the corresponding sheet in the WorkBook.

Import PDF to Excel

posted Jan 29, 2011, 9:50 AM by Ayush Jain   [ updated Jan 29, 2011, 9:54 AM by ayushjain@live.com ]

Here is the Macro to import text from a PDF file to your excel sheet. Make sure you have Adobe Reader 9.0 installed on your PC.

Sub BackToA1()
End Sub

Sub GetPDFnow()

Dim varRetVal As Variant, strFullyPathedFileName As String, strDoIt As String
'Add a new worksheet
Sheets.Add After:=Sheets(Sheets.Count)
'Name it
ActiveSheet.Name = "Input01"
'Back to "A1"
strFullyPathedFileName = "C:\Documents and Settings\ayujain1\Desktop\Excel_Tutorials\Ayush ebooks\14 secret shortcuts of Excel.pdf"
strDoIt = "C:\Program Files\Adobe\Reader 9.0\Reader\AcroRd32.exe " & strFullyPathedFileName
'The Shell command
varRetVal = Shell(strDoIt, 1)
'Clear CutCopyMode
Application.CutCopyMode = False
AppActivate varRetVal
'Wait some time
Application.Wait Now + TimeValue("00:00:03") ' wait 3 seconds

SendKeys "^a"
SendKeys "^c"
'EXIT (Close & Exit)
SendKeys "^q"
'Wait some time
Application.Wait Now + TimeValue("00:00:03") ' wait 3 seconds
'Go back to cell A1
Call BackToA1

End Sub

1-10 of 10