Friday, April 18, 2014

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.

Friday, March 28, 2014

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

Tuesday, March 25, 2014

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

Saturday, March 15, 2014

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

Thursday, March 13, 2014

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

Wednesday, March 12, 2014

Download .*.pdf from Outlook through VBA

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


Thursday, March 6, 2014

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

Wednesday, March 5, 2014

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

Tuesday, February 18, 2014

Select Range out of Filtered Data

Option Explicit
Dim rowcount As Long
Dim mycoll As Collection, myrng As Range, cell, i As Integer, logintime, logouttime
Sub createAttendance()
On Error Resume Next
Set mycoll = New Collection
Application.ScreenUpdating = False
    rowcount = ThisWorkbook.Sheets(1).Range("C7").End(xlDown).Row
    Set myrng = ThisWorkbook.Sheets(1).Range("C7:C" & rowcount)
    For Each cell In myrng
        mycoll.Add cell, CStr(cell)
    Next
    i = 0
    For i = 1 To mycoll.Count

        ThisWorkbook.Sheets(2).Cells(i + 1, 1) = mycoll(i)
        ThisWorkbook.Sheets(1).Range("C6").AutoFilter field:=3, Criteria1:=mycoll(i)
        Set myrng = ThisWorkbook.Sheets(1).Range("A7:A" & rowcount).SpecialCells(xlCellTypeVisible)
        logouttime = Format(WorksheetFunction.Max(myrng), "hh:mm:ss AMPM")
        logintime = Format(WorksheetFunction.Min(myrng), "hh:mm:ss AMPM")
        ThisWorkbook.Sheets(2).Cells(i + 1, 1) = mycoll(i)
        ThisWorkbook.Sheets(2).Cells(i + 1, 2) = logintime
        ThisWorkbook.Sheets(2).Cells(i + 1, 3) = logouttime
        ThisWorkbook.Sheets(2).Cells(i + 1, 4).Formula = "=" & ThisWorkbook.Sheets(2).Cells(i + 1, 3).Address & "-" & ThisWorkbook.Sheets(2).Cells(i + 1, 2).Address
        ThisWorkbook.Sheets(2).Cells(i + 1, 4).NumberFormat = "hh:mm:ss"
    Next
End Sub


Monday, February 17, 2014

Create Pivot Chart Using VBA

Option Explicit
Dim pvttbl As PivotTable, mychart As Chart, chrtrng As Range

Sub createPivotchart()
On Error Resume Next

For Each pvttbl In ThisWorkbook.Sheets(1).PivotTables
    ThisWorkbook.Sheets(1).Range(pvttbl.TableRange2.Address).Delete
Next
    ThisWorkbook.Sheets(1).ChartObjects.Delete
    ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ThisWorkbook.Sheets(2).Range("A1").CurrentRegion.Address).CreatePivotTable tabledestination:=ThisWorkbook.Sheets(1).Range("B6"), tablename:="Pivottable1"
    Set pvttbl = ThisWorkbook.Sheets(1).PivotTables("pivottable1")
    With pvttbl
            .PivotFields("Region").Orientation = xlRowField
            .PivotFields("Category").Orientation = xlRowField
            .PivotFields("product").Orientation = xlRowField
            .PivotFields("Quantity").Orientation = xlDataField
    End With
    'Set pvttbl = Nothing
    Set chrtrng = pvttbl.TableRange2
    Set mychart = Charts.Add
    Set mychart = mychart.Location(xlLocationAsObject, "Product")
 
        With mychart
                .SetSourceData chrtrng
                .Parent.Top = ThisWorkbook.Sheets(1).Range("B6").Top
                .Parent.Width = ThisWorkbook.Sheets(1).Range("B6:M6").Width
                .Parent.Height = ThisWorkbook.Sheets(1).Range("B7:B24").Height
                .Parent.Left = ThisWorkbook.Sheets(1).Range("B7").Left
                .PlotArea.Format.Fill.Visible = msoTrue
                .PlotArea.Format.Fill.TwoColorGradient msoGradientVertical, 1
                .PlotArea.Format.Fill.ForeColor.RGB = RGB(255, 51, 0)
                .PlotArea.Format.Fill.BackColor.RGB = RGB(72, 80, 255)
                .PlotArea.Format.Fill.GradientStops(1).Position = 0.1
                .PlotArea.Format.Fill.GradientStops(2).Position = 0.9
                .ChartArea.Format.Fill.Visible = msoTrue
                .ChartArea.Format.Fill.TwoColorGradient msoGradientVertical, 1
                .ChartArea.Format.Fill.ForeColor.RGB = RGB(255, 51, 0)
                .ChartArea.Format.Fill.BackColor.RGB = RGB(72, 80, 255)
                .ChartArea.Format.Fill.GradientStops(1).Position = 0.1
                .ChartArea.Format.Fill.GradientStops(2).Position = 0.9
                .HasTitle = True
                .ChartTitle.Caption = "Total Quantity"
                .HasLegend = False
                .SeriesCollection(1).Interior.Color = RGB(135, 220, 55)
        End With
End Sub


Download Chart

Create Hyperlinks for all Files in a Folder

Sub createHyperLink()
Dim I As Integer
Dim fl As File
Dim fldr As Folder
Dim sh As Worksheet
Dim fso As FileSystemObject
Dim path As String

With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    path = .SelectedItems(1)
    Range("A1") = "File Name"
End With

I = 2

Set fso = New FileSystemObject
Set fldr = fso.GetFolder(path)
    For Each fl In fldr.Files
        ThisWorkbook.Sheets(1).Cells(I, 1) = fl.Name
            If ThisWorkbook.Sheets(1).Cells(I, 1) = fl.Name Then
                ThisWorkbook.Sheets(1).Cells(I, 1).Select
                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fl.path
            End If
        I = I + 1
    Next fl

End Sub

Sunday, February 16, 2014

Move files from One Folder to another through VBA

Option Explicit
Dim sourcepath, destinationpath As String
Dim fso As Object, fl As Object, i As Integer, j As Integer, k As Integer

Sub movefilesfromFolders()
On Error GoTo errorHandler
 
    'return type Application.getopenfile is variant
    sourcepath = Application.GetOpenFilename(MultiSelect:=True)
 
    If IsArray(sourcepath) = True Then
    Set fso = New Scripting.FileSystemObject
        Application.FileDialog(msoFileDialogFolderPicker).Show
        destinationpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
     
            For i = LBound(sourcepath) To UBound(sourcepath)
             
                fso.movefile sourcepath(i), destinationpath & fso.GetFileName(sourcepath(i))
 
            Next
    Else
        MsgBox "File not selected"
    End If
Exit Sub
errorHandler:
    MsgBox "Error" & Err.Description
 

End Sub

Friday, February 14, 2014

Create Comment Chart via VBA







Option Explicit
Dim cmt As Comment, myrng As Range, rowcount As Long, mychart As Chart
Dim pathname As String, i As Long, datarng As Range, axisrng As Range, captionrange As Range

Private Sub Workbook_Open()


On Error Resume Next
Application.ScreenUpdating = False
    i = 2
    rowcount = ThisWorkbook.Sheets(1).Range("A2").End(xlDown).Row
    pathname = "C:\temp\"
    For i = 2 To rowcount
        Set myrng = ThisWorkbook.Sheets(1).Range("G" & i)
        myrng.Comment.Delete

            Set cmt = myrng.AddComment
            Set mychart = Charts.Add
            Set mychart = mychart.Location(xlLocationAsObject, "Sheet1")
            Set datarng = ThisWorkbook.Sheets(1).Range("B" & i & ":F" & i)
            Set axisrng = ThisWorkbook.Sheets(1).Range("B1:F1")
            Set captionrange = ThisWorkbook.Sheets(1).Range("A" & i)
            mychart.SetSourceData Source:=datarng
            mychart.SeriesCollection(1).XValues = axisrng
            mychart.SetElement msoElementChartTitleAboveChart
            mychart.ChartTitle.Caption = captionrange
            mychart.HasLegend = False
         
            mychart.Export pathname & "temp" & i & ".jpg", "jpg"
            With cmt.Shape
                    .Fill.UserPicture ("C:\temp\temp" & i & ".jpg")
                    .ScaleHeight 2, msoFalse
                    .ScaleWidth 3, msoFalse
            End With
        ThisWorkbook.Sheets(1).ChartObjects.Delete
    Next
    Set myrng = Nothing
    Set mychart = Nothing
    Set datarng = Nothing
    Set axisrng = Nothing
    Set captionrange = Nothing



End Sub


Thursday, February 13, 2014

Sparkline chart through VBA

Option Explicit
Dim myChart As Chart, rowcount As Long, i As Long, myrng As Range, datarng As Range
Sub createcellChart()
On Error Resume Next
i = 2
myrng.SparklineGroups.Clear
rowcount = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
Set myrng = ThisWorkbook.Sheets(1).Range("F2:F" & rowcount)
Set datarng = ThisWorkbook.Sheets(1).Range("A2:E" & rowcount)
myrng.SparklineGroups.Add Type:=xlSparkColumn, SourceData:=datarng.Address
     With myrng.SparklineGroups.Item(1)
        .SeriesColor.Color = RGB(112, 48, 160)
        .LineWeight = 1.5
        With .Points
            .Highpoint.Visible = True
            .Highpoint.Color.Color = RGB(0, 176, 240)
            .Lowpoint.Visible = True
            .Lowpoint.Color.Color = RGB(255, 0, 0)
        End With
    End With

End Sub


https://drive.google.com/file/d/0B23eJ2xd9ODycUJydHM5MEllQTQ/edit?usp=sharing

Tuesday, February 11, 2014

Read & write *.txt file in VBA

Option Explicit
Dim pathname As String, fso As Object, tso As Object, tempfile As String
Dim linecounter As Integer, tempvar, i As Integer
Sub readtextFile()
    With Application.FileDialog(msoFileDialogFolderPicker)
                .Show
                .Title = "Select .txt File to read"
    pathname = .SelectedItems(1)
   
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    tempfile = pathname & "\data.txt"
Set tso = fso.getFile(tempfile).OpenAsTextStream(1, -2)
linecounter = 0
    While Not tso.AtEndofStream() <> False
        linecounter = linecounter + 1
        i = 0
        tempvar = tso.readline
            For Each cell In Split(tempvar, " ")
                i = i + 1
                    Cells(linecounter, 1) = cell
            Next
    Wend
    Set tso = Nothing
    Set fso = Nothing
End Sub



Dim pathname As String, fso As Object, tso As Object, tempfile As String
Dim linecounter As Integer, tempvar, i As Integer
Sub readtextFile()
    With Application.FileDialog(msoFileDialogFolderPicker)
                .Show
                .Title = "Select .txt File to read"
    pathname = .SelectedItems(1)
   
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    tempfile = pathname & "\data.txt"
Set tso = fso.getFile(tempfile).OpenAsTextStream(1, -2)
linecounter = 0
    While tso.AtEndofStream() <> True
        linecounter = linecounter + 1
        i = 0
        tempvar = tso.readline
            For Each cell In Split(tempvar, " ")
                i = i + 1
                    Cells(linecounter, 1) = cell
            Next
    Wend
    Set tso = Nothing
    Set fso = Nothing
End Sub