Autofit Column using VBA

Sub Hidealternatecolumns()

Dim first As Double
Dim last As Double

first = 4
last = 40

For i = first To last

If Cells(1, i).Column Mod 2 = 0 Then
        Cells(1, i).EntireColumn.Hidden = True
    End If
Next
Range("C8").CurrentRegion.Columns.AutoFit

End Sub

DownloadFile

Send mail with Condition

Dim outlukApp As Outlook.Application, outlukMail, daterng As Range, rowcount As Long, cell


Sub sendMail()
rowcount = ThisWorkbook.Sheets("Data").Range("I" & Rows.Count).End(xlUp).Row

Set daterng = ThisWorkbook.Sheets("Data").Range("I2:I" & rowcount)
For Each cell In daterng
Set outlukApp = New Outlook.Application
Set outlukMail = outlukApp.CreateItem(olMailItem)

        If (cell = Date) Then
         
                With outlukMail
             
                    .Display
                    .To = CStr(cell.Offset(0, 3))
                    .Subject = "Intimation Mail"
                    .HTMLBody = "Dear " & "<b>" & cell.Offset(0, 2) & "</b>,<br>        Please find the attachment of....."
                 
     
                End With
                Application.DisplayAlerts = False
                Application.Wait (Now + TimeValue("00:00:05"))
                'Application.SendKeys "%s"
        End If
        Set outlukApp = Nothing
        Set outlukMail = Nothing
     
Next


End Sub

Download File

Multithreading in VBA

A good example in VBA of Multithreading using Application.Ontime


File for downloading

Data Validation With rules

Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address = "$C$2" Then
            Select Case Target.Value
                Case "All"
                                   
                       With ThisWorkbook.Sheets(1).Range("D2").Validation
                            .Delete
                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=allrng"
                       End With
                Case "X"
                        With ThisWorkbook.Sheets(1).Range("D2").Validation
                            .Delete
                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=xrng"
                       End With
                Case "Y"
                        With ThisWorkbook.Sheets(1).Range("D2").Validation
                            .Delete
                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=yrng"
                       End With
            End Select
        End If
End Sub


Download file:

Data Validation with rules

Sort Data based on count on the basis of VBA

Dim mycoll As Collection
Dim myrng As Range, assgnrng As Range, rowcount As Long, cell, i As Integer
Sub sortData()
On Error Resume Next

rowcount = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
Set assgnrng = ThisWorkbook.Sheets(1).Range("A1:A" & rowcount)
    For i = 1 To rowcount
        ThisWorkbook.Sheets(1).Range("E" & (i + 1)) = Application.WorksheetFunction.CountIfs(assgnrng, ThisWorkbook.Sheets(1).Range("A" & (i + 1)))
   
    Next
ThisWorkbook.Sheets(1).Range("A1:E" & rowcount).Copy ThisWorkbook.Sheets(2).Range("A1")
ThisWorkbook.Sheets(2).Range("A2:E" & rowcount).Sort key1:=ThisWorkbook.Sheets(2).Range("E2"), order1:=xlDescending
End Sub

Download file

Advancedfilter Using VBA

Sub testAdvancefilter()
'remove current filter
ThisWorkbook.Sheets("Summary").Range("B10").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
'*********************************
ThisWorkbook.Sheets("Data").Range(ThisWorkbook.Sheets("data").Range("A1").CurrentRegion.Address).AdvancedFilter Action:=xlFilterCopy, criteriarange:=ThisWorkbook.Sheets("Data").Range("M1:P2"), copytorange:=ThisWorkbook.Sheets("Summary").Range("B10"), unique:=True
Columns.AutoFit
End Sub

Download File

Sample file

Application.OnKey Example

Application.Onkey method runs a specified procedure when a particular key or key combination is pressed.


Sub test()
Call onKeyExample(True, True, True, "z", "myprocedure")

End Sub

Sub onKeyExample(shiftkey As Boolean, ctrlkey As Boolean, altkey As Boolean, strkey As String, callfunction As String)
Dim strShift As String
Dim strCtrl As String
Dim stralt As String
    If (shiftkey = True) Then strShift = "+"
    If (ctrlkey = True) Then strCtrl = "^"
    If (altkey = True) Then stralt = "%"
 
 
    Application.OnKey strShift & strCtrl & stralt & "{" & strkey & "}", callfunction
End Sub

Sub myprocedure()
    MsgBox "My Procedure"

End Sub

Scope of Variable

'Procedure Scope
Sub TestSub()
        Dim X As Long
        Dim Y As Long
       
        X = 1234
        Y = 4321
        MsgBox "X: " & X & "Y: " & Y
End Sub
'Module Scope
'Module scope means that a variable can be declared before and outside of any procedure
'in a regular code module. If you use Private or Dim to declare the variable, only procedures
'that are in the same module can access that variable. Since a module level variable is not
'part of any procedure, it will retain its value even after the procedure that changes its
'value has terminated. For example,
'Dim ModVar As Long
'Private ModVar As Long

'Project scope
'Project scope variables are those declared using the Public keyword.
'These variables are accessible from any procedure in any module in the project.
'In Excel, a Project is all of the code modules, userforms, class modules, and object
'modules (e.g,. ThisWorkbook and Sheet1) that are contained within a workbook.
'If you want a variable to be accessible from anywhere within the project, but not accessible
'from another project, you need to use Option Private Module as the first line in the module
'Global Scope
'Global scope variables are those that are accessible from anywhere in the project that
'declares them as well as any other project that references the first project. To declare
'a variable with global scope, you need to declare it using the Public keyword in a module
'that does not use the Option Private Module directive.

Colored table in Outlook HtmlBody

Option Explicit
Dim outlApp As Outlook.Application, outlMailitem As Outlook.MailItem
Dim heading As String, fullbody As String, myrng As Range, rowcount As Long, cell
Sub sendmailsinhtmlBody()



Set outlApp = New Outlook.Application
Set outlMailitem = outlApp.CreateItem(olMailItem)
rowcount = ThisWorkbook.Sheets(1).Range("D6").End(xlDown).Row
Set myrng = ThisWorkbook.Sheets(1).Range("D7:D" & rowcount)
heading = "<table align=" & """center""" & "border=" & """4""" & ",collapsing=4><tr bgcolor=#808080 ><b><td>" & ThisWorkbook.Sheets(1).Range("D6") & "</td><td>" & ThisWorkbook.Sheets(1).Range("e6") & "</td><td>" & ThisWorkbook.Sheets(1).Range("f6") & "</td></b></tr>"
            fullbody = "Hi," & "<br>"
            fullbody = fullbody & "<p>Please find the status below:</p>" & vbNewLine & vbNewLine
            fullbody = fullbody & heading
For Each cell In myrng

         
            fullbody = fullbody & "<tr bgcolor=#CCFFFF ><td>" & cell.Value & "</td><td>" & cell.Offset(0, 1) & "</td><td>" & cell.Offset(0, 2) & "</td></tr>"
Next
            fullbody = fullbody & "</table>"
         
        With outlMailitem
         
                .To = "pc_soumyendu@yahoo.co.in"
                .htmlbody = fullbody
                .Subject = "Daily Report"
                .Display
        End With
 

End Sub

Insert & Delete Entire Row in VBA

Option Explicit
Dim rowcount As Long, myrng As Range
Sub removeBlankcells()

rowcount = ThisWorkbook.Sheets(1).Range("A65500").End(xlUp).Row
    Set myrng = ThisWorkbook.Sheets(1).Range("A2:A" & rowcount)
     ThisWorkbook.Sheets(1).UsedRange.AutoFilter field:=1, Criteria1:=""
     ThisWorkbook.Sheets(1).Range("A1:A" & rowcount).SpecialCells(xlCellTypeBlanks).Select
     Selection.EntireRow.Delete
    ThisWorkbook.Sheets(1).AutoFilterMode = False
End Sub

Option Explicit

Dim rowcount As Long, i As Integer

Sub insertRow()

Application.ScreenUpdating = False

    rowcount = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row

    For i = 2 To (rowcount - 1) * 2

        ThisWorkbook.Sheets(1).Range("A" & (i + 1)).EntireRow.Insert

          i = i + 1

       Next

End Sub

File to downlaod

Extract Data using Querytable in VBA

Querytable example

Use Find Method(VBA) to search fraction

Option Explicit
Dim rowcount As Long, myrng As Range, i As Integer, lookupval As String, lookuprng As Range
Dim totalrng As Range, rownum As Variant
Sub sortData()
rowcount = ThisWorkbook.Sheets(1).Range("D2").End(xlDown).Row

Set myrng = ThisWorkbook.Sheets(1).Range("D1:D" & rowcount)
    i = 1
    For i = 1 To rowcount - 1
        lookupval = Format(Application.WorksheetFunction.Large(myrng, i), "#.00")
       
        With ThisWorkbook.Sheets(1).Range(myrng.Address)
            If InStr(lookupval, ".") > 1 Then
                Set lookuprng = .Find(what:=lookupval, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
            ElseIf (InStr(lookupval, ".")) = 1 Then
                Set lookuprng = .Find(what:=lookupval, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
            End If
        End With
     
        ThisWorkbook.Sheets(1).Range("K" & (i + 1)) = lookupval
        ThisWorkbook.Sheets(1).Range("H" & (i + 1)) = lookuprng.Offset(0, -3)
        ThisWorkbook.Sheets(1).Range("I" & (i + 1)) = lookuprng.Offset(0, -2)
        ThisWorkbook.Sheets(1).Range("J" & (i + 1)) = lookuprng.Offset(0, -1)
     Set lookuprng = Nothing
     lookupval = vbNullString
    Next
End Sub

Download Sample file

Always Create Folder in Desktop through VBA

Sub createFolderinDesktop()
Dim fso As New Scripting.FileSystemObject

Dim wsh As Object
Set wsh = CreateObject("Wscript.shell")

fso.CreateFolder wsh.specialfolders("Desktop") & "\myfldr"




End Sub

Download .*.pdf from Outlook through VBA

File to download

Outlook Application with HTMLBody

Option Explicit
Dim outApp As Outlook.Application, oMailItem As Outlook.MailItem, strBody As String
Dim rowcount As Long, statusrng As Range, cell, heading As String
Sub sendstatuswiseMails()
    Set outApp = New Outlook.Application
 
    rowcount = ThisWorkbook.Sheets(1).Range("G1").End(xlDown).Row
    Set statusrng = ThisWorkbook.Sheets(1).Range("G2:G" & rowcount)
    heading = "<table border=" & """1""" & ",collapsing=1><tr><td>" & Range("A1") & "</td><td> " & Range("B1") & "</td><td> " & Range("C1") & "</td><td> " & Range("D1") & "</td><td width=20> " & Range("E1") & "</td><td width=20> " & Range("F1") & "</td><td> " & Range("H1") & "</td></tr>"
    For Each cell In statusrng
        strBody = vbNullString
        If cell.Value = "True" Then
        Set oMailItem = outApp.CreateItem(olMailItem)
            With oMailItem
                .To = cell.Offset(0, 2)
                strBody = strBody & "Hi," & "<br>"
                strBody = strBody & vbTab & vbTab & vbTab & "<p>Please find the status below</p>" & vbNewLine & vbNewLine
             
                strBody = strBody & heading
                strBody = strBody & "<tr><td>" & cell.Offset(0, -6) & "</td><td>" & cell.Offset(0, -5) & "</td><td>" & cell.Offset(0, -4) & "</td><td>" & cell.Offset(0, -3) & "</td><td>" & cell.Offset(0, -2) & "</td><td>" & cell.Offset(0, -1) & "</td><td>" & cell.Offset(0, 1) & "</td></tr></table>"
                strBody = strBody & "<br><p>Regards,<br>Soumyendu"
                .Subject = "Update for " & cell.Offset(0, -5)
                .HTMLBody = strBody
             
                .Display
                Application.Wait (Now + TimeValue("00:00:03"))
                Application.SendKeys "%s"
            End With
        Set oMailItem = Nothing
        End If
    Next
 
End Sub

File to download

Show Pivot Table as %ofTotal(no calculated field) through VBA

Option Explicit
Dim pvttable As PivotTable
Sub createCalculatedPivottable()
On Error Resume Next
    For Each pvttable In ThisWorkbook.Sheets(2).PivotTables
        ThisWorkbook.Sheets(2).Range(pvttable.TableRange2.Address).Delete
    Next
    ThisWorkbook.PivotCaches.Create(xlDatabase, ThisWorkbook.Sheets(1).Range("B1").CurrentRegion.Address).CreatePivotTable tabledestination:=ThisWorkbook.Sheets(2).Range("B4"), tablename:="Pivottable1"
 
 
    Set pvttable = ThisWorkbook.Sheets(2).PivotTables("Pivottable1")
    With pvttable
        .PivotFields("Afo").Orientation = xlRowField
        .PivotFields("Status").Orientation = xlColumnField
     
        .PivotFields("Paid Amount").Orientation = xlDataField
        .PivotFields("Sum of Paid Amount").Position = 1
        .PivotFields("Sum of Paid Amount").Caption = "PaidAmount"
        .PivotFields("Paid Amount").Orientation = xlDataField
        .PivotFields("Sum of Paid Amount").Position = 2
        .PivotFields("Sum of Paid Amount").Calculation = xlPercentOfTotal
        .PivotFields("Sum of Paid Amount").NumberFormat = "0.00%"
     
        .PivotFields("Sum of Paid Amount").Caption = "%"
 
 
    End With
    ThisWorkbook.ShowPivotTableFieldList = False
    Set pvttable = Nothing
 
End Sub

%ofTotal

Pivot Table with Calculated field

Option Explicit
Dim pvttable As PivotTable
Sub showSummary()
Application.ScreenUpdating = False
On Error Resume Next
    For Each pvttable In ThisWorkbook.Sheets(1).PivotTables
        ThisWorkbook.Sheets(1).Range(pvttable.TableRange2.Address).Delete
 
    Next
 
    ThisWorkbook.PivotCaches.Create(xlDatabase, ThisWorkbook.Sheets(3).Range("a1").CurrentRegion.Address).CreatePivotTable tabledestination:=ThisWorkbook.Sheets(1).Range("c5"), tablename:="Pivottable1"
        Set pvttable = ThisWorkbook.Sheets(1).PivotTables("Pivottable1")
            With pvttable
         
                .PivotFields("Product").Orientation = xlPageField
                .PivotFields("Sales Manager").Orientation = xlRowField
                .PivotFields("Sales Target").Orientation = xlDataField
             
                .PivotFields("Actual Sales").Orientation = xlDataField
             
                .CalculatedFields.Add "Goal Achvd", "='Actual Sales'/'Sales Target'", True
                .PivotFields("Goal Achvd").Orientation = xlDataField
                .PivotFields("Sum of Goal Achvd").NumberFormat = "0.00%"
                .PivotFields("Sum of Goal Achvd").Caption = "Target Achvd in %"
             
            End With
End Sub


File to Download

Find the Language of Text through VBA

File to download:
Langauge Finder

Using Array Formula in VBA

File download for Array Formula

Read OutLook Mails of Particular folder by clicking Hyperlink

Outlook Mail Reader