VBA code.... insert query for new new records update for existing records

Dim conn As ADODB.Connection, rst As ADODB.Recordset, myarray
Dim rowcount As Long, updatequery As String
Dim apprisaldate1 As String, apprisaldate2 As String, apprisaldate3 As String, apprisaldate4 As String, apprisaldate5 As String, apprisaldate6 As String, apprisaldate7 As String, apprisaldate8 As String, apprisaldate9 As String, apprisaldate10 As String
Dim lastsalary1 As String, lastsalary2 As String, lastsalary3 As String, lastsalary4 As String, lastsalary5 As String, lastsalary6 As String, lastsalary7 As String, lastsalary8 As String, lastsalary9 As String, lastsalary10 As String
Dim revisedsalary1 As String, revisedsalary2 As String, revisedsalary3 As String, revisedsalary4 As String, revisedsalary5 As String, revisedsalary6 As String, revisedsalary7 As String, revisedsalary8 As String, revisedsalary9 As String, revisedsalary10 As String
Sub insertecord()
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets(1).AutoFilterMode = False
   ' On Error GoTo errorHandler
    rowcount = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
   
    Set conn = New ADODB.Connection
    Set rst = New ADODB.Recordset
    conn.ConnectionString = "Data Source=HRAutomation;Initial Catalog=KoenigDb;uid=sa;pwd=Pa$$w0rd;"
    conn.Open
    'rst.Open "EmpAppraisal", conn, adOpenKeyset, adLockBatchOptimistic, adCmdTable
    For i = 2 To rowcount
    'MsgBox "Emp Id" & ThisWorkbook.Sheets(1).Range("A" & i)
   
    Set rst = conn.Execute("Select * from EmpAppraisal where [Employee ID]='" & ThisWorkbook.Sheets(1).Range("A" & i) & "';")
    If Not rst.EOF Then
        myarray = rst.GetRows
        If UBound(myarray) > 0 Then
            apprisaldate1 = ThisWorkbook.Sheets(1).Range("B" & i)
            apprisaldate2 = ThisWorkbook.Sheets(1).Range("E" & i)
            apprisaldate3 = ThisWorkbook.Sheets(1).Range("H" & i)
            apprisaldate4 = ThisWorkbook.Sheets(1).Range("K" & i)
            apprisaldate5 = ThisWorkbook.Sheets(1).Range("N" & i)
            apprisaldate6 = ThisWorkbook.Sheets(1).Range("Q" & i)
            apprisaldate7 = ThisWorkbook.Sheets(1).Range("T" & i)
            apprisaldate8 = ThisWorkbook.Sheets(1).Range("W" & i)
            apprisaldate9 = ThisWorkbook.Sheets(1).Range("Z" & i)
            apprisaldate10 = ThisWorkbook.Sheets(1).Range("AC" & i)
           
            lastsalary1 = ThisWorkbook.Sheets(1).Range("C" & i)
            lastsalary2 = ThisWorkbook.Sheets(1).Range("F" & i)
            lastsalary3 = ThisWorkbook.Sheets(1).Range("I" & i)
            lastsalary4 = ThisWorkbook.Sheets(1).Range("L" & i)
            lastsalary5 = ThisWorkbook.Sheets(1).Range("O" & i)
            lastsalary6 = ThisWorkbook.Sheets(1).Range("R" & i)
            lastsalary7 = ThisWorkbook.Sheets(1).Range("U" & i)
            lastsalary8 = ThisWorkbook.Sheets(1).Range("X" & i)
            lastsalary9 = ThisWorkbook.Sheets(1).Range("AA" & i)
            lastsalary10 = ThisWorkbook.Sheets(1).Range("AD" & i)
           
           
            revisedsalary1 = ThisWorkbook.Sheets(1).Range("D" & i)
            revisedsalary2 = ThisWorkbook.Sheets(1).Range("G" & i)
            revisedsalary3 = ThisWorkbook.Sheets(1).Range("J" & i)
            revisedsalary4 = ThisWorkbook.Sheets(1).Range("M" & i)
            revisedsalary5 = ThisWorkbook.Sheets(1).Range("P" & i)
            revisedsalary6 = ThisWorkbook.Sheets(1).Range("S" & i)
            revisedsalary7 = ThisWorkbook.Sheets(1).Range("V" & i)
            revisedsalary8 = ThisWorkbook.Sheets(1).Range("Y" & i)
            revisedsalary9 = ThisWorkbook.Sheets(1).Range("AB" & i)
            revisedsalary10 = ThisWorkbook.Sheets(1).Range("AE" & i)
            updatequery = "Update EmpAppraisal set [Appraisal/Increment Date1]='" & apprisaldate1 & "',[Last Salary1]='" & lastsalary1 & "',[Revised Salary1]='" & revisedsalary1 & "',[Appraisal/Increment Date2]='" & apprisaldate2 & "',[Last Salary2]='" & lastsalary2 & "',[Revised Salary2]='" & revisedsalary2 & "',[Appraisal/Increment Date3]='" & apprisaldate3 & "',[Last Salary3]='" & lastsalary3 & "',[Revised Salary3]='" & revisedsalary3 & "',[Appraisal/Increment Date4]='" & apprisaldate4 & "',[Last Salary4]='" & lastsalary4 & "',[Revised Salary4]='" & revisedsalary4 & "',[Appraisal/increment Date5]='" & apprisaldate5 & "',[Last Salary5]='" & lastsalary5 & "',[Revised Salary5]='" & revisedsalary5 & "',[Appraisal/increment Date6]='" & apprisaldate6 & "',[Last Salary6]='" & lastsalary6 & "',[Revised Salary6]='" & revisedsalary6 & "',[Appraisal/increment Date7]='" & apprisaldate7 & "',[Last Salary7]='" & lastsalary7 & "',[Revised Salary7]='" & revisedsalary7 & "',[Appraisal/increment Date8]='" & apprisaldate8 _
& "',[Last Salary8]='" & lastsalary8 & "',[Revised Salary8]='" & revisedsalary8 & "',[Appraisal/increment Date9]='" & apprisaldate9 & "',[Last Salary9]='" & lastsalary9 & "',[Revised Salary9]='" & revisedsalary9 & "',[Appraisal/increment Date10]='" & apprisaldate10 & "',[Last Salary10]='" & lastsalary10 & "',[Revised Salary10]='" & revisedsalary10 & "' where [Employee ID]='" & ThisWorkbook.Sheets(1).Range("A" & i) & "';"
            conn.Execute (updatequery)
        Else
            apprisaldate1 = ThisWorkbook.Sheets(1).Range("B" & i)
            apprisaldate2 = ThisWorkbook.Sheets(1).Range("E" & i)
            apprisaldate3 = ThisWorkbook.Sheets(1).Range("H" & i)
            apprisaldate4 = ThisWorkbook.Sheets(1).Range("K" & i)
            apprisaldate5 = ThisWorkbook.Sheets(1).Range("N" & i)
            apprisaldate6 = ThisWorkbook.Sheets(1).Range("Q" & i)
            apprisaldate7 = ThisWorkbook.Sheets(1).Range("T" & i)
            apprisaldate8 = ThisWorkbook.Sheets(1).Range("W" & i)
            apprisaldate9 = ThisWorkbook.Sheets(1).Range("Z" & i)
            apprisaldate10 = ThisWorkbook.Sheets(1).Range("AC" & i)
           
            lastsalary1 = ThisWorkbook.Sheets(1).Range("C" & i)
            lastsalary2 = ThisWorkbook.Sheets(1).Range("F" & i)
            lastsalary3 = ThisWorkbook.Sheets(1).Range("I" & i)
            lastsalary4 = ThisWorkbook.Sheets(1).Range("L" & i)
            lastsalary5 = ThisWorkbook.Sheets(1).Range("O" & i)
            lastsalary6 = ThisWorkbook.Sheets(1).Range("R" & i)
            lastsalary7 = ThisWorkbook.Sheets(1).Range("U" & i)
            lastsalary8 = ThisWorkbook.Sheets(1).Range("X" & i)
            lastsalary9 = ThisWorkbook.Sheets(1).Range("AA" & i)
            lastsalary10 = ThisWorkbook.Sheets(1).Range("AD" & i)
           
           
            revisedsalary1 = ThisWorkbook.Sheets(1).Range("D" & i)
            revisedsalary2 = ThisWorkbook.Sheets(1).Range("G" & i)
            revisedsalary3 = ThisWorkbook.Sheets(1).Range("J" & i)
            revisedsalary4 = ThisWorkbook.Sheets(1).Range("M" & i)
            revisedsalary5 = ThisWorkbook.Sheets(1).Range("P" & i)
            revisedsalary6 = ThisWorkbook.Sheets(1).Range("S" & i)
            revisedsalary7 = ThisWorkbook.Sheets(1).Range("V" & i)
            revisedsalary8 = ThisWorkbook.Sheets(1).Range("Y" & i)
            revisedsalary9 = ThisWorkbook.Sheets(1).Range("AB" & i)
            revisedsalary10 = ThisWorkbook.Sheets(1).Range("AE" & i)
           
           
insertquery = "insert EmpAppraisal([Employee ID], [Appraisal/Increment Date1],[Last Salary1],[Revised Salary1],[Appraisal/Increment Date2],[Last Salary2],[Revised Salary2],[Appraisal/Increment Date3],[Last Salary3],[Revised Salary3],[Appraisal/Increment Date4],[Last Salary4],[Revised Salary4],[Appraisal/increment Date5],[Last Salary5],[Revised Salary5],[Appraisal/increment Date6],[Last Salary6],[Revised Salary6],[Appraisal/increment Date7],[Last Salary7],[Revised Salary7],[Appraisal/increment Date8],[Last Salary8],[Revised Salary8],[Appraisal/increment Date9],[Last Salary9],[Revised Salary9],[Appraisal/increment Date10],[Last Salary10],[Revised Salary10])" _
& "values('" & empId & "','" & apprisaldate1 & "','" & lastsalary1 & "','" & revisedsalary1 & "','" & apprisaldate2 & "','" & lastsalary2 & "','" & revisedsalary2 & "','" & apprisaldate3 & "','" & lastsalary3 & "','" & revisedsalary3 & "','" & apprisaldate4 & "','" & lastsalary4 & "','" & revisedsalary4 & "','" & apprisaldate5 & "','" & lastsalary5 & "','" & revisedsalary5 & "','" & apprisaldate6 & "'," _
& "'" & lastsalary6 & "','" & revisedsalary6 & "','" & apprisaldate7 & "','" & lastsalary7 & "','" & revisedsalary7 & "','" & apprisaldate8 _
& "','" & lastsalary8 & "','" & revisedsalary8 & "','" & apprisaldate9 & "','" & lastsalary9 & "','" & revisedsalary9 & "','" & apprisaldate10 & "','" & lastsalary10 & "','" & revisedsalary10 & "');"
            conn.Execute (insertquery)
            'ThisWorkbook.Sheets(1).Range("B4") = insertquery
        End If
    Else
            empId = ThisWorkbook.Sheets(1).Range("A" & i)
            apprisaldate1 = ThisWorkbook.Sheets(1).Range("B" & i)
            apprisaldate2 = ThisWorkbook.Sheets(1).Range("E" & i)
            apprisaldate3 = ThisWorkbook.Sheets(1).Range("H" & i)
            apprisaldate4 = ThisWorkbook.Sheets(1).Range("K" & i)
            apprisaldate5 = ThisWorkbook.Sheets(1).Range("N" & i)
            apprisaldate6 = ThisWorkbook.Sheets(1).Range("Q" & i)
            apprisaldate7 = ThisWorkbook.Sheets(1).Range("T" & i)
            apprisaldate8 = ThisWorkbook.Sheets(1).Range("W" & i)
            apprisaldate9 = ThisWorkbook.Sheets(1).Range("Z" & i)
            apprisaldate10 = ThisWorkbook.Sheets(1).Range("AC" & i)
           
            lastsalary1 = ThisWorkbook.Sheets(1).Range("C" & i)
            lastsalary2 = ThisWorkbook.Sheets(1).Range("F" & i)
            lastsalary3 = ThisWorkbook.Sheets(1).Range("I" & i)
            lastsalary4 = ThisWorkbook.Sheets(1).Range("L" & i)
            lastsalary5 = ThisWorkbook.Sheets(1).Range("O" & i)
            lastsalary6 = ThisWorkbook.Sheets(1).Range("R" & i)
            lastsalary7 = ThisWorkbook.Sheets(1).Range("U" & i)
            lastsalary8 = ThisWorkbook.Sheets(1).Range("X" & i)
            lastsalary9 = ThisWorkbook.Sheets(1).Range("AA" & i)
            lastsalary10 = ThisWorkbook.Sheets(1).Range("AD" & i)
           
           
            revisedsalary1 = ThisWorkbook.Sheets(1).Range("D" & i)
            revisedsalary2 = ThisWorkbook.Sheets(1).Range("G" & i)
            revisedsalary3 = ThisWorkbook.Sheets(1).Range("J" & i)
            revisedsalary4 = ThisWorkbook.Sheets(1).Range("M" & i)
            revisedsalary5 = ThisWorkbook.Sheets(1).Range("P" & i)
            revisedsalary6 = ThisWorkbook.Sheets(1).Range("S" & i)
            revisedsalary7 = ThisWorkbook.Sheets(1).Range("V" & i)
            revisedsalary8 = ThisWorkbook.Sheets(1).Range("Y" & i)
            revisedsalary9 = ThisWorkbook.Sheets(1).Range("AB" & i)
            revisedsalary10 = ThisWorkbook.Sheets(1).Range("AE" & i)
           
           
insertquery = "insert EmpAppraisal([Employee ID], [Appraisal/Increment Date1],[Last Salary1],[Revised Salary1],[Appraisal/Increment Date2],[Last Salary2],[Revised Salary2],[Appraisal/Increment Date3],[Last Salary3],[Revised Salary3],[Appraisal/Increment Date4],[Last Salary4],[Revised Salary4],[Appraisal/increment Date5],[Last Salary5],[Revised Salary5],[Appraisal/increment Date6],[Last Salary6],[Revised Salary6],[Appraisal/increment Date7],[Last Salary7],[Revised Salary7],[Appraisal/increment Date8],[Last Salary8],[Revised Salary8],[Appraisal/increment Date9],[Last Salary9],[Revised Salary9],[Appraisal/increment Date10],[Last Salary10],[Revised Salary10])" _
& "values('" & empId & "','" & apprisaldate1 & "','" & lastsalary1 & "','" & revisedsalary1 & "','" & apprisaldate2 & "','" & lastsalary2 & "','" & revisedsalary2 & "','" & apprisaldate3 & "','" & lastsalary3 & "','" & revisedsalary3 & "','" & apprisaldate4 & "','" & lastsalary4 & "','" & revisedsalary4 & "','" & apprisaldate5 & "','" & lastsalary5 & "','" & revisedsalary5 & "','" & apprisaldate6 & "'," _
& "'" & lastsalary6 & "','" & revisedsalary6 & "','" & apprisaldate7 & "','" & lastsalary7 & "','" & revisedsalary7 & "','" & apprisaldate8 _
& "','" & lastsalary8 & "','" & revisedsalary8 & "','" & apprisaldate9 & "','" & lastsalary9 & "','" & revisedsalary9 & "','" & apprisaldate10 & "','" & lastsalary10 & "','" & revisedsalary10 & "');"
            'ThisWorkbook.Sheets(1).Range("B4") = insertquery
            conn.Execute (insertquery)
           
   
   
    End If
  
   
       
    Next
     
           
           
       
        'End If
 'Next
End Sub


Download File

Select Query in For Loop using VBA

Dim conn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rowcount As Long, emprng As Range
Dim mycoll As Collection, i As Integer
Dim myArray(), rowcounter As Integer, counter As Integer
Sub updateclaimedtrainingDays()
rowcount = ThisWorkbook.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
Set emprng = ThisWorkbook.Sheets(1).Range("D2:D" & rowcount)
Set mycoll = New Collection
On Error Resume Next
'startdate = CDate("10/27/2015")
'endDate = CDate("10/28/2015")
conn.ConnectionString = "Data Source=TADA;Initial Catalog=Firdb;uid=kshrNew;pwd=A343jNMS;"
conn.Open
For Each cell In emprng
    mycoll.Add cell, CStr(cell)
Next
counter = 0
For i = 1 To mycoll.Count
        Set rst = conn.Execute("Select t2.DaysQty from tblTADATransDetail t2 where t2.TAId IN( Select t1.TAId  from tblTADATransMaster  t1 where (t1.CreatedDate >= '" & startdate & "' and t1.CreatedDate <='" & endDate & "') And t1.EmpId='" & mycoll(i) & "')and t2.NameOfExpenditure='1. Training Incentives'")
        If Not rst.EOF Then
            'cell.Offset(0, 16).CopyFromRecordset rst.Fields(4).Value
            myArray = rst.GetRows()
            rowcounter = UBound(myArray, 2)
            For j = 0 To rowcounter
            counter = counter + 1
           
                ThisWorkbook.Sheets(1).Range("T" & (1 + counter)) = myArray(0, j)
            Next
        Else
        counter = counter + 1
            ThisWorkbook.Sheets(1).Range("T" & (1 + counter)) = 0
        End If
Next
 rst.Close
Set rst = Nothing
Set conn = Nothing

End Sub

Add ValidationList in VBA

ThisWorkbook.Sheets(1).Range("B6").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=" & validationrng.Address

Extracting Excel Cell value with Multple Lines

'extracting cell value with multiple lines
        If (InStr(clientname, Chr(10)) > 0) Then
            tempArray = Split(clientname, Chr(10))
            clientname = tempArray(0)
        End If

Using adOpenStatic in Databse Connectivity(VBA)

Dim conn As New ADODB.Connection
Dim rst As New ADODB.Recordset, rowcount As Long
Dim sqlqyerystr As String, coulumncounter As Long, rowcounter As Long
Sub updaterecord()
'On Error Resume Next
Application.ScreenUpdating = False
rowcount = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
ThisWorkbook.Sheets(1).Range("A2:S" & rowcount).ClearContents
conn.ConnectionString = "Data Source=TADA;Initial Catalog=Firdb;uid=kshr;pwd=A343jNMS;"
conn.Open
sqlqyerystr = "Select * from tblnewjoineeemployeedetail ;"

rst.Open sqlqyerystr, conn, adOpenStatic
Dim myArray()
myArray = rst.GetRows()
MsgBox "updating File for New Employee.........."
coulumncounter = UBound(myArray, 1)
rowcounter = UBound(myArray, 2)
For j = 0 To rowcounter
    For i = 0 To coulumncounter
   
        ThisWorkbook.Sheets(1).Range("A1").Offset(0, i).Value = rst.Fields(i).Name
        ThisWorkbook.Sheets(1).Range("A1").Offset(j + 1, i).Value = myArray(i, j)
       
    Next
Next
rst.Close
conn.Close
rowcount = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
ThisWorkbook.Sheets(1).Range("A1:AM1").AutoFilter Field:=39, Criteria1:="<" & Format(Date, "m/d/yyyy")
ThisWorkbook.Sheets(1).Range("AM2:AM" & rowcount).SpecialCells(xlCellTypeVisible).EntireRow.Delete
ThisWorkbook.Sheets(1).AutoFilterMode = False
Set rst = Nothing
Set conn = Nothing
End Sub

Autofilter Automation inbetween two Dates

Dim myArray(3) As String, lookuprng As Range
Public rowcount As Long, wb As Workbook
Public sheetname As String, newrowcount As Long, datarng As Range, tempval As Integer
Private Sub CommandButton1_Click()
''On Error Resume Next
tempval = 0
    For j = 0 To 3
   
    sheetname = Format(CDate(TextBox1.Value), "mmm") & "'" & Format(CDate(TextBox1.Value), "yy")
   
    rowcount = ThisWorkbook.Sheets(sheetname).Range("B" & Rows.Count).End(xlUp).Row
    Set lookuprng = ThisWorkbook.Sheets(sheetname).Range("A:A").Find(myArray(j), LookIn:=xlValues)
   
        If lookuprng Is Nothing Then
            ThisWorkbook.Sheets(sheetname).Range("A" & rowcount + 3) = myArray(j)
            ThisWorkbook.Sheets(sheetname).Range("B" & rowcount + 3) = TextBox1.Value & "-" & TextBox2.Value
            ThisWorkbook.Sheets(sheetname).Range("A" & (rowcount + 3) & ":B" & (rowcount + 3)).Font.Bold = True
        Exit For
        End If
    Next
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\Onsite Report.xlsx")
    newrowcount = wb.Sheets(sheetname).Range("B" & Rows.Count).End(xlUp).Row
    i = 0
    wb.Sheets(sheetname).AutoFilterMode = False
    wb.Sheets(sheetname).Range("A1:T1").AutoFilter field:=3, Criteria1:=">=" & TextBox1.Value, Operator:=xlAnd, Criteria2:="<=" & TextBox2.Value
   
    Set datarng = wb.Sheets(sheetname).Range("B4:B" & newrowcount).SpecialCells(xlCellTypeVisible)
    For Each cell In datarng
        i = i + 1
        ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 5 + i)) = cell
        ThisWorkbook.Sheets(sheetname).Range("C" & (rowcount + 5 + i)) = cell.Offset(0, 7)
        ThisWorkbook.Sheets(sheetname).Range("D" & (rowcount + 5 + i)) = cell.Offset(0, 10)
        ThisWorkbook.Sheets(sheetname).Range("E" & (rowcount + 5 + i)) = cell.Offset(0, 15)
        ThisWorkbook.Sheets(sheetname).Range("F" & (rowcount + 5 + i)) = cell.Offset(0, 6)
        ThisWorkbook.Sheets(sheetname).Range("G" & (rowcount + 5 + i)) = cell.Offset(0, 4)
         tempval = tempval + CInt(ThisWorkbook.Sheets(sheetname).Range("G" & (rowcount + 5 + i)))
    Next
    ThisWorkbook.Sheets(sheetname).Range("G" & (rowcount + 6 + i)) = tempval
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Application.DisplayAlerts = False
    wb.Close
    Unload Me
End Sub
Private Sub UserForm_Initialize()
On Error Resume Next
'Application.ScreenUpdating = False
TextBox1.Value = Format(Date, "d-mmm-yy")
TextBox2.Value = Format(Date, "d-mmm-yy")

myArray(0) = "Week 1"
myArray(1) = "Week 2"
myArray(2) = "Week 3"
myArray(3) = "Week 4"

End Sub

Download File

Adding Controls Dynamically in User Form

Private Sub ComboBox1_Change()
Dim searchval As String, thelbl As Object, thelbl1 As Object, txtbox As Object
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
ThisWorkbook.Sheets(2).Range("B2") = ComboBox1.Value
For Each cont In Me.Controls
    Me.Controls.Remove cont.Name
Next
Application.Calculation = xlCalculationAutomatic
If (Application.WorksheetFunction.CountIf(ThisWorkbook.Sheets(2).Range("E:E"), ">0") + 1) > 2 Then
    Set myrng1 = ThisWorkbook.Sheets(2).Range("E2:E" & Application.WorksheetFunction.CountIf(ThisWorkbook.Sheets(2).Range("E:E"), ">0") + 1)
Else
    Set myrng1 = ThisWorkbook.Sheets(2).Range("E2:E3")
End If
ComboBox1.List = myrng1.Value
cellrow = CLng(Application.WorksheetFunction.Match(CInt(ComboBox1.Value), ThisWorkbook.Sheets(1).Range("F:F"), 0))
Set lookupadd = ThisWorkbook.Sheets(1).Range("F3:F" & ThisWorkbook.Sheets(1).Cells(Rows.Count, 6).End(xlUp).Row).Find(Application.WorksheetFunction.Trim(ComboBox1.Value), LookIn:=xlValues)

    Set lblName = Existingemp.Controls.Add("Forms.Label.1", "Name", True)
    Set lblNameval = Existingemp.Controls.Add("Forms.Label.1", "Name", True)
    Set lblStatus = Existingemp.Controls.Add("Forms.Label.1", "Status", True)
    Set lblResignationDate = Existingemp.Controls.Add("Forms.Label.1", "ResignDate", True)
    Set txtBoxResignationDate = Existingemp.Controls.Add("Forms.TextBox.1", "ResignDate", True)
    Set lblNoticeDuration = Existingemp.Controls.Add("Forms.Label.1", "NoticeDuration", True)
    Set txtBoxNoticeDuration = Existingemp.Controls.Add("Forms.TextBox.1", "NoticeDuration", True)
    Set lblRelvDate = Existingemp.Controls.Add("Forms.Label.1", "RelvDate", True)
    Set txtBoxRelvDate = Existingemp.Controls.Add("Forms.TextBox.1", "RelvDate", True)
    Set lblOffLast = Existingemp.Controls.Add("Forms.Label.1", "OffLast", True)
    Set txtBoxOffLast = Existingemp.Controls.Add("Forms.TextBox.1", "OffLast", True)
    Set lblOffEmailIdStatus = Existingemp.Controls.Add("Forms.Label.1", "OffEmailIdStatus", True)
    Set txtBoxOffEmailIdStatus = Existingemp.Controls.Add("Forms.TextBox.1", "OffEmailIdStatus", True)
    Set lblHandoverAssetData = Existingemp.Controls.Add("Forms.Label.1", "HandoverAssetData", True)
    Set cmbboxHandoverAssetData = Existingemp.Controls.Add("Forms.ComboBox.1", "HandoverAssetData", True)
    Set lblExitInterview = Existingemp.Controls.Add("Forms.Label.1", "ExitInterview", True)
    Set cmbExitInterview = Existingemp.Controls.Add("Forms.ComboBox.1", "ExitInterview", True)
    Set lblReleivingLetterStatus = Existingemp.Controls.Add("Forms.Label.1", "ReleivingLetterStatus", True)
    Set cmbReleivingLetterStatus = Existingemp.Controls.Add("Forms.ComboBox.1", "ReleivingLetterStatus", True)
    Set lblFandF = Existingemp.Controls.Add("Forms.Label.1", "FandF", True)
    Set cmbFandF = Existingemp.Controls.Add("Forms.ComboBox.1", "FandF", True)
    Set lblRemark = Existingemp.Controls.Add("Forms.Label.1", "Remark", True)
    Set txtRemark = Existingemp.Controls.Add("Forms.TextBox.1", "Remark", True)
    Set cmbbox = Existingemp.Controls.Add("Forms.ComboBox.1", "cmbbox", True)
   
   
        With lblName
            .BackColor = RGB(141, 180, 226)
            .Caption = "Name"
            .Font.Bold = True
            .Left = 124
            .Width = 36
            .Top = 7
            .BorderStyle = 1
            .Height = 16
        End With
        With lblNameval
           
            .BackColor = RGB(141, 180, 226)
            .Font.Bold = True
            .Caption = ThisWorkbook.Sheets(1).Range(lookupadd.Address).Offset(0, -3) & " " & ThisWorkbook.Sheets(1).Range(lookupadd.Address).Offset(0, -2) & " " & ThisWorkbook.Sheets(1).Range(lookupadd.Address).Offset(0, -1)
            .Left = 160
            .Width = 127
            .Top = 7
            .BorderStyle = 1
            .Height = 16
        End With
        With lblResignationDate
            .BackColor = RGB(255, 153, 102)
            .Caption = "Resignation Date"
            .Font.Bold = True
            .Left = 10
            .Width = 75
            .Top = 55
            .BorderStyle = 1
            .Height = 15
        End With
        With txtBoxResignationDate
           
            .Value = Format(Date, "mm/dd/yyyy")
            .Font.Bold = True
            .Left = 85
            .Width = 75
            .Top = 55
            .BorderStyle = 1
            .Height = 15
        End With
        With lblNoticeDuration
            .BackColor = RGB(255, 153, 102)
            .Caption = "Notice Durartion"
            .Font.Bold = True
            .Left = 10
            .Width = 75
            .Top = 70.5
            .BorderStyle = 1
            .Height = 20
        End With
        With txtBoxNoticeDuration
           
           
            .Font.Bold = True
            .Left = 85
            .Width = 75
            .Top = 70.5
            .BorderStyle = 1
            .Height = 20
        End With
        With lblRelvDate
            .BackColor = RGB(255, 153, 102)
            .Caption = "Releieving Date"
            .Font.Bold = True
            .Left = 10
            .Width = 75
            .Top = 91.5
            .BorderStyle = 1
            .Height = 15
        End With
        With txtBoxRelvDate
           
            .Value = Format(Date + 60, "mm/dd/yyyy")
            .Font.Bold = True
            .Left = 85
            .Width = 75
            .Top = 91.5
            .BorderStyle = 1
            .Height = 15
        End With
        With lblOffLast
            .BackColor = RGB(255, 153, 102)
            .Caption = "Official Last Date"
            .Font.Bold = True
            .Left = 10
            .Width = 75
            .Top = 107
            .BorderStyle = 1
            .Height = 15
        End With
        With txtBoxOffLast
           
            .Value = Format(Date + 60, "mm/dd/yyyy")
            .Font.Bold = True
            .Left = 85
            .Width = 75
            .Top = 107
            .BorderStyle = 1
            .Height = 15
        End With
       
        With lblOffEmailIdStatus
            .BackColor = RGB(255, 153, 102)
            .Caption = "Off. Emailid Status"
            .Font.Bold = True
            .Left = 175
            .Width = 81
            .Top = 55
            .BorderStyle = 1
            .Height = 15
        End With
        With txtBoxOffEmailIdStatus
           
           
            .Font.Bold = True
            .Left = 256
            .Width = 220
            .Top = 55
            .BorderStyle = 1
            .Height = 15
        End With
        With lblHandoverAssetData
            .BackColor = RGB(255, 153, 102)
            .Caption = "Handover Asset & Data"
            .Font.Bold = True
            .Left = 175
            .Width = 81
            .Top = 70.5
            .BorderStyle = 1
            .Height = 20
        End With
        With cmbboxHandoverAssetData
           
            .List = Array("Yes", "No", "Not Required")
            .Font.Bold = True
            .Left = 256
            .Width = 40
            .Top = 70.5
            .BorderStyle = 1
            .Height = 20
        End With
        With lblExitInterview
            .BackColor = RGB(255, 153, 102)
            .Caption = "Exit Interview"
            .Font.Bold = True
            .Left = 175
            .Width = 81
            .Top = 91.5
            .BorderStyle = 1
            .Height = 15
        End With
        With cmbExitInterview
           
            .List = Array("Yes", "No", "Not Required")
            .Font.Bold = True
            .Left = 256
            .Width = 40
            .Top = 91.5
            .BorderStyle = 1
            .Height = 15
        End With
        With lblReleivingLetterStatus
            .BackColor = RGB(255, 153, 102)
            .Caption = "Releiving Letter"
            .Font.Bold = True
            .Left = 175
            .Width = 81
            .Top = 107
            .BorderStyle = 1
            .Height = 15
        End With
        With cmbReleivingLetterStatus
           
            .List = Array("Issued", "Pending", "Not Required")
            .Font.Bold = True
            .Left = 256
            .Width = 40
            .Top = 107
            .BorderStyle = 1
            .Height = 15
        End With
        With lblFandF
            .BackColor = RGB(255, 153, 102)
            .Caption = "F&F Status"
            .Font.Bold = True
            .Left = 10
            .Width = 75
            .Top = 122.5
            .BorderStyle = 1
            .Height = 15
        End With
        With cmbFandF
           
            .List = Array("Yes", "No", "On Hold", "Not Required")
            .Font.Bold = True
            .Left = 85
            .Width = 40
            .Top = 122.5
            .BorderStyle = 1
            .Height = 15
        End With
        With lblRemark
            .BackColor = RGB(255, 153, 102)
            .Caption = "Remark"
            .Font.Bold = True
            .Left = 175
            .Width = 81
            .Top = 122.5
            .BorderStyle = 1
            .Height = 15
        End With
        With txtRemark
           
           
            .Font.Bold = True
            .Left = 256
            .Width = 220
            .Top = 122.5
            .BorderStyle = 1
            .Height = 15
        End With
        With lblStatus
            .Caption = "Status"
            .Font.Bold = True
            .BackColor = RGB(255, 153, 102)
            .Left = 350
            .Width = 75
            .Top = 140
            .BorderStyle = 1
            .Height = 14.5
        End With
       
       
        With cmbbox
            .List = Array("Resigned")
            .Left = 425.5
            .Width = 51
            .Top = 140
            .BorderStyle = 1
            .Height = 14.5
           
        End With
Existingemp.Height = 180
Existingemp.Width = 481

Application.EnableEvents = True
End Sub

Sending Emails with Image signature in Outlook

Dim outlukApp As Outlook.Application, outlukMailItm As Outlook.MailItem, emailid, myval, i As Integer, fullbody As String
Dim sigstring As String, signature As String
Sub sendMail()
    Set outlukApp = New Outlook.Application
    Set outlukMailItm = outlukApp.CreateItem(olMailItem)
    myval = Application.InputBox("Enter Mutiple  EmailId with ; delimiter", "EmailId")
    On Error Resume Next
    If myval = False Then
        Exit Sub
    Else
         emailid = Split(myval, ";")
        
       
         For i = 0 To UBound(emailid)
          fullbody = "Dear," & "<br>"
          fullbody = fullbody & "<p>Please find the attachment of new joinee details</p><br><br>"
          fullbody = fullbody & "<br> Best Regards,"
             With outlukMailItm
                     .Display
                     .To = emailid(i)
                    
                     .Subject = "New Joinee Details"
                     .HTMLBody = "Dear,<br>" & "<p>Please find the attachment of new joinee details</p><br><br><br> Best Regards," & .HTMLBody
                     .Attachments.Add (ThisWorkbook.Path & "\" & ThisWorkbook.Name)
                     .Display
                     Application.DisplayAlerts = False
                     .Send
             End With
            
            
         Next
     End If
    Set outlukMailItm = Nothing
    Set outlukApp = Nothing
   
End Sub

Copy filtered Data with Criteria

Dim rowcount As Long, myrng As Range, cell
Sub copyFilteredData()
rowcount = ThisWorkbook.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
Set myrng = ThisWorkbook.Sheets(1).Range("B2:B" & rowcount)
For Each cell In myrng
        If cell.Value Like "*LF*" Then
            cell.Offset(0, 1) = 0
        Else
            cell.Offset(0, 1) = 1
        End If
Next
ThisWorkbook.Sheets(1).Range("A1:B" & rowcount).AutoFilter field:=2, Criteria1:="*LF*"
ThisWorkbook.Sheets(1).Range("A1:B" & rowcount).SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Sheets("Lost").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
ThisWorkbook.Sheets(1).ShowAllData
ThisWorkbook.Sheets(1).Range("A1:B" & rowcount).AutoFilter field:=2, Criteria1:="<>*LF*"
ThisWorkbook.Sheets(1).Range("A1:B" & rowcount).SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Sheets("State").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll

End Sub

Download file
 

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

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