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

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

Download File

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

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

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

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

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

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

Generate Chart on Worksheet_Change Event

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$2" Then
        Select Case Target.Value
            Case "SOUTH"
                Call createGraph(Target.Value)
     
            Case "WEST"
                Call createGraph(Target.Value)
            Case "NORTH"
                Call createGraph(Target.Value)
            Case "MIDWEST"
                Call createGraph(Target.Value)
         
        End Select
    End If
End Sub


Dim myChart As Chart, rowcount As Long, datarng As Range, axisrng As Range
Public Sub createGraph(mycriteria As String)
'On Error Resume Next
Application.ScreenUpdating = False
    ThisWorkbook.Sheets("Dashboard").Range(ThisWorkbook.Sheets("Dashboard").Range("D6").CurrentRegion.Address).Clear
    ThisWorkbook.Sheets(2).Range("A1").AutoFilter Field:=1, Criteria1:=mycriteria
    ThisWorkbook.Sheets(2).UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(1).Range("D6")
    ThisWorkbook.Sheets(1).ChartObjects.Delete
    rowcount = ThisWorkbook.Sheets(1).Range("D6").End(xlDown).Row
    Set datarng = ThisWorkbook.Sheets(1).Range("J7:J" & rowcount)
    Set axisrng = ThisWorkbook.Sheets(1).Range("D7:D" & rowcount)

    Set myChart = Charts.Add
    Set myChart = myChart.Location(xlLocationAsObject, "Dashboard")
 
        With myChart
            .Parent.Top = ThisWorkbook.Sheets(1).Range("D6").Top
            .Parent.Left = ThisWorkbook.Sheets(1).Range("D10").Left
            .Parent.Width = ThisWorkbook.Sheets(1).Range("D10:J10").Width
            .Parent.Height = ThisWorkbook.Sheets(1).Range("D6:D20").Height
            .SetSourceData Source:=datarng
            .SeriesCollection(1).XValues = axisrng
            .HasTitle = True
            .ChartType = xlColumnClustered
            .SetElement (msoElementChartTitleAboveChart)
            .ChartTitle.Caption = "Sales amount for " & mycriteria
        End With
    End Sub


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

Change Pivottable Datafield Function

Option Explicit
Dim pvttable As PivotTable
Sub createPivottable()
On Error Resume Next
For Each pvttable In ThisWorkbook.Sheets("Soum").PivotTables
    ThisWorkbook.Sheets("Soum").Range(pvttable.TableRange2.Address).Delete
Next
    ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ThisWorkbook.Sheets(3).Range("a2").CurrentRegion.Address).createPivottable tabledestination:=ThisWorkbook.Sheets("Soum").Range("C6"), tablename:="Pivottable1"
    With ThisWorkbook.Sheets("Soum").PivotTables("Pivottable1")
            .PivotFields("Product Name").Orientation = xlRowField
            .PivotFields("HelpColumn").Orientation = xlColumnField
            .PivotFields("Base Amount").Orientation = xlDataField
           ThisWorkbook.Sheets("Soum").Range("D8").PivotField.Function = xlSum
    End With
 
End Sub

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

Copy Range in a Faster Way

Option Explicit
Dim rawdata, myrng As Range
Sub copyRange()
rawdata = ThisWorkbook.Sheets(1).Range("a1:b1726")
ThisWorkbook.Sheets(2).Range("a1").Resize(UBound(rawdata, 1), UBound(rawdata, 2)) = rawdata
End Sub

Split File and send e-mail with Attachment

Task : split an excel file into separate files using particular customer
codes and then email these directly to a particular email account depending
on the  customer code(column A).



Option Explicit
Dim mycoll As Collection, rowcount As Long, myrng As Range, cell As Object, j As Long
Dim destinationwb As Workbook, outApp As Outlook.Application, outMail, newwb As Workbook

Sub createFiles()
Set mycoll = New Collection
On Error Resume Next
rowcount = ThisWorkbook.Sheets(1).Range("A3").End(xlDown).Row

Set myrng = ThisWorkbook.Sheets(1).Range("A3:A" & rowcount)
    For Each cell In myrng
        mycoll.Add cell, CStr(cell)


    Next
    For j = 1 To mycoll.Count
    Set outApp = New Outlook.Application
    Set outMail = outApp.CreateItem(olMailItem)
    Set destinationwb = Workbooks.Add
    destinationwb.SaveAs Filename:=ThisWorkbook.Path & "\" & mycoll(j), FileFormat:=56
        ThisWorkbook.Sheets(1).Range("A2").AutoFilter field:=1, Criteria1:=mycoll(j)
        ThisWorkbook.Sheets(1).UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=destinationwb.Sheets(1).Range("A1")
         Set newwb = ActiveWorkbook
     
     
        destinationwb.Save
        With outMail
            .To = mycoll(j) & "@yahoo.com"
            .Subject = "Monthly Account Summary"
         
            .Body = "Hi," & vbNewLine & "     Please find the attachment" & vbNewLine & "Regards," & vbNewLine & "Soumyendu"
         
            .Attachments.Add (ThisWorkbook.Path & "\" & newwb.Name)
            .Display
         
        End With
        Application.DisplayAlerts = False
        destinationwb.Close

         Application.DisplayAlerts = False
         Application.Wait (Now + TimeValue("0:00:02"))
         Application.SendKeys "%s" '
        Set outMail = Nothing
     
        Set outApp = Nothing
     
    Next
End Sub

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

Insert Data Through VBA

Option Explicit
Dim conn As New ADODB.Connection

Dim querystring As String
Dim id As Integer, empname As String, age As Integer, address As String, salary As Long, i As Integer, rowcount As Long
Sub insertData()
i = 2
On Error Resume Next
conn.ConnectionString = "Provider=SQL Native Client ;Integrated Security=SSPI; Data Source=New\SQLExpress;Initial Catalog=Somu"
rowcount = ThisWorkbook.Sheets(1).Range("a2").End(xlDown).Row

conn.Openq

    For i = 2 To (rowcount - 1)

            id = CInt(ThisWorkbook.Sheets(1).Range("A" & (i + 1)))
            empname = ThisqWorkbook.Sheets(1).Range("B" & (i + 1))
            age = CInt(ThisWorkbook.Sheets(1).Range("C" & (i + 1)))
            address = ThisWorkbook.Sheets(1).Range("D" & (i + 1))
            salary = CLng(ThisWorkbook.Sheets(1).Range("E" & (i + 1)))
            querystring = "Insert into Customers(Id, EmpName,Age,Address,Salary) values(" & id & ",'" & empname & "' ," & age & ",' " & address & "'," & salary & ")"
         
            conn.Execute querystring
 
    Next
conn.Close
Set conn = Nothing

End Sub

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

Sort IP Address

Option Explicit
Dim rowcount As Long, myrng As Range, cell As Object, cell1 As Object



Sub sortIPAddress()
rowcount = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
Set myrng = ThisWorkbook.Sheets(1).Range("A1:A" & rowcount)
    For Each cell In myrng
      cell.Offset(0, 1) = WorksheetFunction.Substitute(cell, ".", "")
      cell.NumberFormat = "#"
   
    Next
 
    ThisWorkbook.Sheets(1).Range("B1:B" & rowcount).Sort key1:=Range("B1"), Header:=xlYes
    For Each cell1 In ThisWorkbook.Sheets(1).Range("B2:B" & rowcount)
            cell1 = Mid(cell1, 1, 3) & "." & Mid(cell1, 4, 3) & "." & Mid(cell1, 7, 1) & "." & Mid(cell1, 8, Len(cell1) - 7)
         
    Next
    ThisWorkbook.Sheets(1).Range("B1:B" & rowcount).Columns.AutoFit
End Sub

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

Employee Status report in Userform with Autofilter in VBA

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

Lock/Unlock Range with Criteria

Sub showParameter()
 
    If ThisWorkbook.Sheets(2).Range("J1") = 1 Then
       With ThisWorkbook.Worksheets(1)
                .Protect Password:="123india", UserInterfaceonly:=True, DrawingObjects:=False, Contents:=True, AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True
                .Cells.Locked = False
                .Range("A1:E50").Locked = True
                .EnableSelection = xlNoRestrictions
                .EnableOutlining = True
      End With
    ElseIf ThisWorkbook.Sheets(2).Range("J1") = 2 Then
        With ThisWorkbook.Worksheets(1)
                .Protect Password:="123india", UserInterfaceonly:=True, DrawingObjects:=False, Contents:=True, AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True
                .Cells.Locked = False
                .Range("A1:E50").Locked = True
                .EnableSelection = xlNoRestrictions
                .EnableOutlining = True
      End With
    End If

End Sub

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

Convert Excel file to *.CSV

Option Explicit
Dim rowcount As Long, filepath As String
Sub convertoCSV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    rowcount = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
    With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select a path to store file"
            If .Show = True Then
                filepath = .SelectedItems(1) & "\"
                'converting into text format
                ThisWorkbook.Sheets(1).Range("A:A").NumberFormat = "@"
                ThisWorkbook.SaveAs Filename:=filepath & "Somu.csv", FileFormat:=xlCSV, CreateBackup:=False
         
            Else
                MsgBox "Folder for *.CSV file not selected"
            End If
 
    End With


End Sub

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

Cut & Paste using VBA Code

Task for attached link:
https://drive.google.com/file/d/0B23eJ2xd9ODyUEtOVk4zRWt4VDA/edit?usp=sharing

Want to cut all these HQ names from column B and paste them to the very next column C

VBA Code



Option Explicit
Dim lookupval As String, myrng As Range, firstaddress As String
Sub copyHOnamelist()

lookupval = "HQ Name:"
With ThisWorkbook.Sheets(1).Range("A:A")
Set myrng = .Find(lookupval, LookIn:=xlValues)

    
    If Not myrng Is Nothing Then
        firstaddress = myrng.Address
            Do
                
                myrng.Offset(0, 1).Cut Destination:=myrng.Offset(0, 2)
                Set myrng = .FindNext(myrng)
                
                     
        
                
            Loop While Not myrng Is Nothing And myrng.Address <> firstaddress
            
    End If
End With

End Sub

VBA Code to Split Word

Sl. No.	Name with No Space	Output
1	RahulSaxena	Rahul Saxena
2	PramodSingh	Pramod Singh
3	ManishSharma	Manish Sharma
4	DhirenMathur	Dhiren Mathur
5	RavindraKumarJena	Ravindra Kumar Jena
6	RamSinghTohan	Ram Singh Tohan
7	SurjitSinghManhas	Surjit Singh Manhas

Function splitWord(myval As String)

Dim tiny As String, finalword As String

finalword = myval

    For i = 1 To Len(myval)

        

        tiny = Mid(myval, i, 1)

            If (tiny = StrConv(tiny, vbUpperCase)) Then

            finalword = WorksheetFunction.Substitute(finalword, tiny, " " & tiny)

            

            End If

    Next

    splitWord = WorksheetFunction.Trim(finalword)

End Function

Create PivotTable with Criteria In VBA

Dim pvttable As PivotTable
Private Sub worksheet_change(ByVal target As Range)
    If target.Address = ThisWorkbook.Sheets("Soum").Range("C3").Address Then
        Select Case ThisWorkbook.Sheets("Soum").Range("C3")
            Case "Daily Report"
               Call createdailyReport
            Case "Weekly Report"
               Call createdweeklyReport
            Case "Monthly Report"
                Call createdmonthlyReport
 
        End Select
     
    End If
End Sub

Sub createdailyReport()
On Error Resume Next
Application.ScreenUpdating = False
For Each pvttable In ThisWorkbook.Sheets("Soum").PivotTables
    ThisWorkbook.Sheets("Soum").Range(pvttable.TableRange2.Address).Delete

Next
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ThisWorkbook.Sheets("Dump").Range("A2").CurrentRegion.Address).CreatePivotTable tabledestination:=ThisWorkbook.Sheets("Soum").Range("C6"), tablename:="Pivottable1"
    With ThisWorkbook.Sheets("Soum").PivotTables("Pivottable1")
        .PivotFields("Date").Orientation = xlRowField
        .PivotFields("Agent Name").Orientation = xlPageField
        '
        .PivotFields("ACD Calls").Orientation = xlDataField
     
        .PivotFields("Avg ACD Time").Orientation = xlDataField
        .PivotFields("Sum of ACD Calls").Caption = "Total ACD Calls"
        .PivotFields("Sum of Avg ACD Time").Caption = "Average ACD Time"


    End With
End Sub

Sub createdmonthlyReport()
On Error Resume Next
Application.ScreenUpdating = False
For Each pvttable In ThisWorkbook.Sheets("Soum").PivotTables
    ThisWorkbook.Sheets("Soum").Range(pvttable.TableRange2.Address).Delete

Next
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ThisWorkbook.Sheets("Dump").Range("A2").CurrentRegion.Address).CreatePivotTable tabledestination:=ThisWorkbook.Sheets("Soum").Range("C6"), tablename:="Pivottable1"
    With ThisWorkbook.Sheets("Soum").PivotTables("Pivottable1")
        .PivotFields("Date").Orientation = xlRowField
        Sheets("Soum").Range("C8").Select
        Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, False, True, False, False)
        .PivotFields("Agent Name").Orientation = xlPageField
        '.PivotFields("ACD Calls").Orientation = xlColumnField
        .PivotFields("ACD Calls").Orientation = xlDataField
     
        .PivotFields("Avg ACD Time").Orientation = xlDataField
        .PivotFields("Sum of ACD Calls").Caption = "Total ACD Calls"
        .PivotFields("Sum of Avg ACD Time").Caption = "Average ACD Time"
       ' .PivotFields("Date").LabelRange.Group Start:=True, End:=True, Periods:=Array(False, False, False, _
        'False, True, False, False)



    End With
End Sub

Sub createdweeklyReport()
'On Error Resume Next
Application.ScreenUpdating = False
For Each pvttable In ThisWorkbook.Sheets("Soum").PivotTables
    ThisWorkbook.Sheets("Soum").Range(pvttable.TableRange2.Address).Delete

Next
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ThisWorkbook.Sheets("Dump").Range("A2").CurrentRegion.Address).CreatePivotTable tabledestination:=ThisWorkbook.Sheets("Soum").Range("C6"), tablename:="Pivottable1"
    With ThisWorkbook.Sheets("Soum").PivotTables("Pivottable1")
        .PivotFields("Date").Orientation = xlRowField
        Sheets("Soum").Range("C8").Select
        Selection.Group Start:=True, End:=True, by:=7, Periods:=Array(False, _
        False, False, True, False, False, False)
        .PivotFields("Agent Name").Orientation = xlPageField
        '.PivotFields("ACD Calls").Orientation = xlColumnField
        .PivotFields("ACD Calls").Orientation = xlDataField
     
        .PivotFields("Avg ACD Time").Orientation = xlDataField
        .PivotFields("Sum of ACD Calls").Caption = "Total ACD Calls"
        .PivotFields("Sum of Avg ACD Time").Caption = "Average ACD Time"
       ' .PivotFields("Date").LabelRange.Group Start:=True, End:=True, Periods:=Array(False, False, False, _
        'False, True, False, False)



    End With
End Sub


For file:

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

Copy Specific Cells from files under Folder/SubFolder

Option Explicit
Dim objFso As Object, objFolder As Object, pathname As String, eachfile As Variant, objFolder1 As Object, eachfolder As Object
Dim tempcounter As Long, wb As Workbook, i As Integer, j As Integer


Sub copyFromSpecificfolderandsubfolder()
On Error Resume Next
pathname = "D:\Somu\ExcelClasses Notes"
Set objFso = New Scripting.FileSystemObject
Set objFolder = objFso.GetFolder(pathname)
Set objFolder1 = objFolder.SubFolders
Set wb = ThisWorkbook
tempcounter = 1
Call readfile(objFolder, tempcounter)

For Each eachfolder In objFolder1

Call readfile(eachfolder, tempcounter)

Next
tempcounter = 0
End Sub

Sub readfile(myFolder As Scripting.Folder, tempcounter)

For Each eachfile In myFolder.Files
    If checkExtension(eachfile) = True Then
        tempcounter = tempcounter + 1
 
        Workbooks.Open eachfile
        ActiveWorkbook.Sheets(1).Range("A2:C2").Copy wb.Sheets(1).Range("A" & tempcounter)
        ActiveWorkbook.Close
    End If
Next
End Sub

Public Function checkExtension(eachfile) As Boolean
i = InStr(1, eachfile, ".")
j = Len(eachfile)

Select Case Mid(eachfile, i + 1, (j - i))
    Case "xls"
        checkExtension = True
    Case "Xlsm"
        checkExtension = True
    Case "xlsx"
        checkExtension = True
    Case "xlsb"
        checkExtension = True
    Case Else
        checkExtension = False
End Select
End Function

Split data of a Single workbook into different workbook

Option Explicit
Dim wb As Workbook, ws As Worksheet, myrng As Range, i As Integer, x As Integer
Dim fso As Object, fldr As Object, fl As Object, item_, itemcol As Collection
Dim path As String, rawdata
Sub migrateData()
Application.ScreenUpdating = False
On Error Resume Next
path = "D:\Somu\Task12092013-3"
 Set fso = New Scripting.FileSystemObject
 Set fldr = fso.GetFolder(path)
 Set itemcol = New Collection
 'For Each fl In fldr.Files
 Set wb = ThisWorkbook
 Set ws = wb.ActiveSheet
 MsgBox ws.UsedRange.Address
 Set myrng = ws.Range(ws.UsedRange.Address)
 item_ = ws.Range("d2:" & ws.Range("d2").End(xlDown).Address).Value
  For i = 1 To UBound(item_, 1)
        itemcol.Add item_(i, 1), item_(i, 1)

  Next
  For x = 1 To itemcol.Count
    myrng.AutoFilter , field:=4, Criteria1:=itemcol(x)
    rawdata = ws.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible)
        For Each fl In fldr.Files
               If Left(fl.Name, InStr(1, fl.Name, ".") - 1) = itemcol(x) Then
                Workbooks.Open path & "\" & fl.Name
                ActiveWorkbook.ActiveSheet.Range("a" & ActiveSheet.UsedRange.Rows.Count).Resize(UBound(rawdata, 1), UBound(rawdata, 2)) = rawdata
                ActiveWorkbook.Save
                ActiveWorkbook.Close
               Else
                    Workbooks.Add
                    ActiveWorkbook.ActiveSheet.Range("a1") = "City"
                    ActiveWorkbook.ActiveSheet.Range("b1") = "Map Code"
                    ActiveWorkbook.ActiveSheet.Range("c1") = "Model"
                    ActiveWorkbook.ActiveSheet.Range("d1") = "Country"
                    ActiveWorkbook.ActiveSheet.Range("e1") = "Batch Refference"
                    ActiveWorkbook.ActiveSheet.Range("f1") = "Source"
                    ActiveWorkbook.ActiveSheet.Range("a2").Resize(UBound(rawdata, 1), UBound(rawdata, 2)) = rawdata
                    ActiveWorkbook.SaveAs path & "\" & itemcol(x), FileFormat:=56
                    ActiveWorkbook.Close
                    Exit For
               End If
 
        Next
  Next
End Sub


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

A Simple VBA Code for Creating PivotTable

Dim pttbl As PivotTable
Sub createPivot()
On Error Resume Next
For Each pttbl In ThisWorkbook.Sheets(2).PivotTables
        ThisWorkbook.Sheets(2).Range(pttbl.TableRange2.Address).Delete
Next

   ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ThisWorkbook.Sheets(1).Range("A1").CurrentRegion.Address). _
   CreatePivotTable TableDestination:=ThisWorkbook.Sheets(2).Range("C5"), TableName:="PivotTable1"
    With ThisWorkbook.Sheets(2).PivotTables("PivotTable1")
        .PivotFields("Processed by").Orientation = xlRowField
        .PivotFields("status").Orientation = xlDataField
        .PivotFields("Transaction type").Orientation = xlPageField
     
    End With

End Sub




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

Sending Attachment through OutLook

Sub sendMail
Dim outApp As New Outlook.Application, outMail As Variant,mailId as String
Set outMail = outApp.CreateItem(olMailItem)
        With outMail
            .To = mailId
            .Subject = Mid(wb.Name, 1, InStr(wb.Name, ".") - 1)
            .Body = "Hi," & vbNewLine & "     Please find the attachment" & vbNewLine & "Regards," &        vbNewLine & "Soumyendu"
            .Attachments.Add (wb.Path & "\" & wb.Name)
         
            .Display
        End With
    wb.Close


End sub

Count Colored Cells through VBA

Option Explicit
Dim myrng As Range, rowcount As Integer, criteria As Range, cell As Variant, criteriaIndex As Long
Dim tempcounter As Long
Function countColoredcells(ByVal criteria As Range) As Long
rowcount = Sheets(3).Range("A1").End(xlDown).Row
Set myrng = ThisWorkbook.Sheets(3).Range("A1:A" & rowcount)
tempcounter = 0
    criteriaIndex = criteria.Interior.ColorIndex
    For Each cell In myrng
        If (cell.Interior.ColorIndex = criteriaIndex) Then
          tempcounter = tempcounter + 1
        End If
    Next
    countColoredcells = tempcounter
End Function

VBA Code for Autofilter with dynamic criteria

Option Explicit
Dim myrng As Range
Dim rowcount As Byte
Dim cell As Variant
Dim MyArray() As Variant, temp As Integer



Sub filterwithdynamicArray()
rowcount = Sheets(1).Range("H2").End(xlDown).Row
temp = 0

Set myrng = Sheets(1).Range("H2:H" & rowcount)
    For Each cell In myrng
        temp = temp + 1
        ReDim Preserve MyArray(1 To temp)
        MyArray(temp) = cell
    Next cell
    Sheets(1).Range("A1").AutoFilter field:=2, Criteria1:=MyArray, Operator:=xlFilterValues
End Sub

File to download:

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

CustomPercentile Function using VBA

Option Explicit
Option Base 1
Dim notemptyrng As Boolean
Function customPercentile(myrng As Range, myval As Double) As Variant
Dim Data() As Double
Dim i  As Long, j As Long, nearestRank As Long
    If isRangeEmpty(myrng) = False Then
            customPercentile = "Input Range is Empty"
            Exit Function
    End If
    If (myval < 0 Or myval > 100) Then
        customPercentile = "Percentile must be between 0& 100"
   
    End If
    ReDim Data(myrng.Rows.Count * myrng.Columns.Count)
    For i = 1 To myrng.Rows.Count
        For j = 1 To myrng.Columns.Count
                If IsNumeric(myrng.Cells(i, j)) = True Then
                    Data(i * j) = myrng.Cells(i, j)
                Else
                    customPercentile = "Error exists in" & myrng.Cells(i, j).Address
                    Exit Function
                End If
        Next
    Next
    Call myBubbleSort(Data)
    nearestRank = Round(myval / 100 * (myrng.Rows.Count * myrng.Columns.Count) + 0.5, 0)
   
    Select Case myval
        Case 0: customPercentile = Data(1)
        Case Else: customPercentile = Data(nearestRank)
    End Select
   
End Function

Function isRangeEmpty(myrng1 As Range) As Boolean
        notemptyrng = False
        If Application.WorksheetFunction.CountA(myrng1) > 0 Then
            notemptyrng = True
        End If
        isRangeEmpty = notemptyrng
End Function

Function myBubbleSort(myArray() As Double) As Variant
    Dim i As Long
    Dim j As Long
    Dim tempval As Variant
    For i = LBound(myArray) To UBound(myArray) - 1
        For j = i + 1 To UBound(myArray)
                If myArray(i) > myArray(j) Then
                tempval = myArray(j)
                myArray(j) = myArray(i)
                myArray(i) = tempval
                End If
        Next
    Next
End Function

Updating Master File Using VBA

VBA Code for updating Master file sheet by different name from other other workbooks with same sheet name under  folder( with same sheet name)




Option Explicit
Dim fso As FileSystemObject
Dim fl As file
Dim fldr As Folder, i As Integer
Dim wb As Workbook, rowcount As Integer, rowcount1 As Integer
Sub updateSheet()
On Error Resume Next
Application.ScreenUpdating = False
Set fso = New FileSystemObject
For i = 4 To ThisWorkbook.Sheets.Count
     
    If (fso.FolderExists(ThisWorkbook.Path & "\" & Sheets(i).Name) = True) Then
     
      Set fldr = fso.GetFolder(ThisWorkbook.Path & "\" & Sheets(i).Name & "\")
      rowcount = ThisWorkbook.Sheets(i).Range("a2").End(xlDown).Row
   
        For Each fl In fldr.Files
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & Sheets(i).Name & "\" & fl.Name)
            rowcount1 = wb.Sheets(1).Range("A2").End(xlDown).Row
         
            wb.Sheets(1).Range("A2:T" & rowcount1).Copy Destination:=ThisWorkbook.Sheets(i).Range("A" & rowcount)
            wb.Close
            Set wb = Nothing
        Next
    End If
Next
End Sub

Convert File Format in a Folder

VBA code for converting excel files to *.xls format in a folder

Option Explicit
Dim pathname As String, fso As New Scripting.FileSystemObject, folder, fl As Object
Sub renameFiles()

      With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select folder"
            If .Show = True Then
                pathname = .SelectedItems(1)

            Else
                MsgBox "Folder not selected"
            End If

      End With
      Set folder = fso.GetFolder(pathname)
   
      For Each fl In folder.Files
   
           If fso.GetExtensionName(pathname & "\" & fl.Name) Like "xl*" Then
                        fl.Name = "Somu.xls"
             
           End If
      Next
      Set folder = Nothing
      Set fso = Nothing
End Sub

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

Update table via deleting records

Option Explicit
Dim clearedData As Range, cell As Range
Dim deletedataCounter As Byte
Sub updateDat()
    Set clearedData = Sheets(2).Range("A2:A" & Sheets(2).Range("A2").CurrentRegion.Rows.Count)
    [a1].Select
    deletedataCounter = 0
    Do
        ActiveCell.Offset(1, 0).Select
            For Each cell In clearedData
                If ActiveCell.Value = cell.Value Then
                  Range(ActiveCell.Address, ActiveCell.Offset(0, 2)).Select
                  Selection.Delete xlShiftUp
                  deletedataCounter = deletedataCounter + 1
                End If
            Next cell
    Loop Until ActiveCell.Value = ""
    MsgBox deletedataCounter & "Cheques Cleared" & [a1].CurrentRegion.Rows.Count & "Pending"
    Set clearedData = Nothing
End Sub

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

Copy Range from Another Workbook through VBA

Option Explicit
Dim fso As FileSystemObject
Dim fl As File
Dim fldr As Folder
Public wb As Workbook, wbnew As Workbook
Dim fldrpath As String
Sub trackSheet()
Set wb = ThisWorkbook
On Error GoTo ErrorHandler
Set fso = New Scripting.FileSystemObject
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choose Folder"
Application.FileDialog(msoFileDialogFolderPicker).Show
fldrpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Set fldr = fso.GetFolder(fldrpath)
For Each fl In fldr.Files
    wb.Sheets.Add after:=Sheets(Sheets.Count)
 
    wb.Sheets(Sheets.Count).Name = fl.Name
Call copySheet(fldrpath & fl.Name)


Next
Set wb = Nothing
Exit Sub
ErrorHandler:

MsgBox "Select Folder"

End Sub



Sub copySheet(ByVal pathname As String)
 i = InStr(pathname, ".")
 extn = Mid(pathname, i, Len(pathname) - (i - 1))
 If extn Like ".xl*" Then
        Set wbnew = Workbooks.Open(pathname)
        Application.DisplayAlerts = False
        wbnew.Sheets(1).UsedRange.Copy Destination:=wb.Sheets(wb.Sheets.Count).Range("A1")
        wb.Save
        wbnew.Close
 End If
End Sub

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

Application.Caller Example in VBA

Option Explicit
Dim myrng As Range
Dim shp As Shape
Sub displayData()
Set shp = ThisWorkbook.Sheets(1).Shapes(Application.Caller)

        Select Case shp.TextFrame.Characters.Text
            Case "Display Data Hiding Zero"
                  shp.TextFrame.Characters.Text = "Display all Data"
                  For Each myrng In Range("D2:D23")
                     If myrng = 0 Then myrng.EntireRow.Hidden = True
                 
                  Next
            Case Else
                  shp.TextFrame.Characters.Text = "Display Data Hiding Zero"
                  Cells.EntireRow.Hidden = False
        End Select

End Sub

For details about Application.Caller plz refer:

http://msdn.microsoft.com/en-us/library/bb220902%28v=office.12%29.aspx

Example file link

https://docs.google.com/file/d/0B23eJ2xd9ODyZXNHNktaeWlFUkU/edit?usp=sharing

Bubble Sort in VBA

Option Explicit
Dim myarray(), lookuprange As Range
Dim myrng As Range, mycell, i As Integer, k As Integer, l As Integer, tempvar

Sub sortarrangeData()
Application.ScreenUpdating = False
ReDim myarray(countUnique(Sheets(1).Range("A2:A31")))
Set myrng = ThisWorkbook.Sheets(1).Range("A2:A31")
For Each mycell In myrng
        If mycell <> mycell.Offset(1, 0) Then
            myarray(i) = mycell
            i = i + 1
         
        End If
Next
i = 0
'bubble sort
For k = 0 To countUnique(Sheets(1).Range("A2:A31")) - 1
    For l = k + 1 To countUnique(Sheets(1).Range("A2:A31"))
         If myarray(k) > myarray(l) Then
            tempvar = myarray(k)
            myarray(k) = myarray(l)
            myarray(l) = tempvar
         End If
       
       
    Next
 
Next
For l = 1 To countUnique(Sheets(1).Range("A2:A31"))
 
    Set lookuprange = ThisWorkbook.Sheets(1).Cells.Find(myarray(l), LookIn:=xlValues, lookat:=xlWhole)
    'MsgBox myarray(l) & "Addess" & lookuprange.Address
    Cells(l + 1, 5) = myarray(l)
    Cells(l + 1, 6) = lookuprange.Offset(0, 1)
    Cells(l + 1, 7) = lookuprange.Offset(1, 1)
    Cells(l + 1, 8) = lookuprange.Offset(2, 1)
Next
End Sub


Function countUnique(rng As Range) As Long
Dim coll As New Collection
Dim cell As Variant

On Error Resume Next
    For Each cell In rng
     
        coll.Add CStr(cell.Value), CStr((cell.Value))

    Next
    countUnique = coll.Count
 
    Set coll = Nothing
End Function

https://docs.google.com/file/d/0B23eJ2xd9ODyWUtvbUpJZ08wbE0/edit?usp=sharing

VBA Sample Code for Two Dimensional Array

Option Explicit
Dim daterng As Range, otherrng As Range, i As Integer, j As Integer, tempCounter As Integer, tempcounternew As Integer
Dim tempcounternew1 As Integer, tempcounternew2 As Integer, tempcounternew3 As Integer
Dim myArray()
Sub realignmentofreport()
Set daterng = ThisWorkbook.Sheets(1).Range("B10:B13")
Set otherrng = ThisWorkbook.Sheets(1).Range("B3:B6")
tempCounter = 0
tempcounternew = 0
tempcounternew1 = 0
tempcounternew2 = 0
tempcounternew3 = 0
On Error Resume Next
    ReDim myArray(1 To daterng.Rows.Count * 5, 1 To otherrng.Rows.Count)
    For i = 1 To UBound(myArray())
   
        tempCounter = tempCounter + 1
       
              
        Select Case (tempCounter < 6)
            Case True
               
                tempcounternew = tempcounternew + 2
                myArray(i, 1) = ThisWorkbook.Sheets(1).Range("B10")
                myArray(i, 2) = ThisWorkbook.Sheets(1).Range("B10").Offset(0, tempcounternew)
                myArray(i, 3) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B10").Offset(0, tempcounternew - 1), [lookuprng], 2, 0)
                myArray(i, 4) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B10").Offset(0, tempcounternew - 1), [lookuprng], 3, 0)
            Case Else
                Select Case (tempCounter < 11) And (tempCounter > 5)
                Case True
                    tempcounternew1 = tempcounternew1 + 2
                   
                    myArray(i, 1) = ThisWorkbook.Sheets(1).Range("B11")
                    myArray(i, 2) = ThisWorkbook.Sheets(1).Range("B11").Offset(0, tempcounternew1)
                    myArray(i, 3) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B11").Offset(0, tempcounternew1 - 1), [lookuprng], 2, 0)
                    myArray(i, 4) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B11").Offset(0, tempcounternew1 - 1), [lookuprng], 3, 0)
                 Case Else
                    Select Case (tempCounter < 16) And (tempCounter > 10)
                        Case True
                            tempcounternew2 = tempcounternew2 + 2
                           
                            myArray(i, 1) = ThisWorkbook.Sheets(1).Range("B12")
                            myArray(i, 2) = ThisWorkbook.Sheets(1).Range("B12").Offset(0, tempcounternew2)
                            myArray(i, 3) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B12").Offset(0, tempcounternew2 - 1), [lookuprng], 2, 0)
                            myArray(i, 4) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B12").Offset(0, tempcounternew2 - 1), [lookuprng], 3, 0)
                   
                        Case Else
                            Select Case (tempCounter < 21) And (tempCounter > 15)
                                Case True
                                    tempcounternew3 = tempcounternew3 + 2
                                   
                                    myArray(i, 1) = ThisWorkbook.Sheets(1).Range("B13")
                                    myArray(i, 2) = ThisWorkbook.Sheets(1).Range("B13").Offset(0, tempcounternew3)
                                    myArray(i, 3) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B13").Offset(0, tempcounternew3 - 1), [lookuprng], 2, 0)
                                    myArray(i, 4) = Application.WorksheetFunction.VLookup(ThisWorkbook.Sheets(1).Range("B13").Offset(0, tempcounternew3 - 1), [lookuprng], 3, 0)
                            End Select
                    End Select
                End Select
        End Select
       
       
  Next
    Sheets(1).Range("H19").Resize(tempCounter, UBound(myArray, 2)) = myArray
End Sub
 https://drive.google.com/file/d/0B23eJ2xd9ODyQTY0blFYRk9McVU/edit?usp=sharing

VBA Code to Display Which Button was Pressed

Sub ClickonwhichButton()

         ' Assign the calling object to a variable.
         ButtonName = Application.Caller

         ' Display the name of the button that was clicked.
         Select Case ButtonName

            ' NOTE: When you type the name of the button, note that
            ' Visual Basic is case and space sensitive when comparing                                                
            ' strings. For example, "Button 6" and "button6" are not the 
            ' same.
            Case "Button 6"
            MsgBox Application.Caller & "  was Clicked"

            Case "Button 7"
            MsgBox Application.Caller & " was clicked."

            Case "Button 8"
            MsgBox Application.Caller & " was clicked."

         End Select

End Sub

Extracting Button Caption on a Click Event of a Button

'Assign this macro to button


Sub test()
MsgBox ActiveSheet.Buttons(Application.Caller).Caption
End Sub

Load MultipleImageFilename in Excel Using VBA

Dim fl, i As Integer, fildialog As Variant

Sub LoadImageFile()
 Set fildialog = Application.FileDialog(msoFileDialogFilePicker)
    With fildialog
        .AllowMultiSelect = True
         .Title = "Select Image"
        .Filters.Clear
     
        .Filters.Add "Image Files", "*.jpg,*.bmp,*.png,*.gif"
        i = 1
        If .Show = True Then
                    For Each fl In .SelectedItems
                        ThisWorkbook.Sheets(1).Range("A" & i) = fl
                   
                        i = i + 1
                    Next
        Else
            MsgBox "Precess cancelled"
        End If
    End With
End Sub