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