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

Virtual Key Code List

For Reference:


http://msdn.microsoft.com/en-us/library/ms927178.aspx

Updation of file using VBA

First update data from raw file to final file , second  when i do any changes in raw file it will automatic change in final workbook. Keep both files in same folder


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

Using # In If Condition

# is used only for numeric values in VBA


Option Explicit
Dim mydata, tempval, i

Sub getData()
mydata = Application.InputBox("Enter Data", "Data", Type:=2)
For i = 1 To Len(mydata)
    If Mid(mydata, i, 1) Like "#" Then
        tempval = tempval & Mid(mydata, i, 1)
    End If
Next i
MsgBox tempval
tempval = vbNullString
End Sub

Finding files name from folders/Subfolders

first of all you will add FSO References

Step for Add:- Tools-Reference-Microsoft Scripting Runtime
and try below code

Sub File_name()

Dim fso As FileSystemObject
Dim fl As File
Dim fldr As Folder
Dim wb As Workbook
Set wb = ThisWorkbook
Set fso = New FileSystemObject
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choose Folder"
Application.FileDialog(msoFileDialogFolderPicker).Show
Dim fldpath As String
fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
& "\"
Set fldr = fso.GetFolder(fldpath)
i = 2
For Each fl In fldr.Files
Sheet3.Cells(i, "D").Value = fl.Name
i = i + 1
Next fl
End Sub

Form Control vs. ActiveX Control in MS Excel

Difference	ActiveX Controls	Excel Controls
Excel versions	97, 2000	5, 95, 97, 2000
Which toolbar?	Control Toolbox	Forms
Controls available	CheckBox, TextBox, CommandButton, OptionButton, ListBox, ComboBox, ToggleButton, SpinButton, ScrollBar, Label, Image	Label, GroupBox, Button, CheckBox, OptionButton, ListBox, ComboBox, ScrollBar, Spinner
Macro code storage	In the code module for the Sheet	In any standard VBA module
Macro name	Corresponds to the control name (e.g., CommandButton1_Click)	Any name you specify.
Correspond to...	UserForm controls	Dialog Sheet controls
Customization	Extensive, using the Properties box	Minimal
Respond to events	Yes	Click or Change events only

Convert Time Zone through VBA

Option Explicit
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Private Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(31) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(31) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
'Purpose     :  Converts local time to GMT.
'Inputs      :  dtLocalDate                 The local data time to return as GMT.
'Outputs     :  Returns the local time in GMT.
'Author      :  Andrew Baker
'Date        :  13/11/2002 10:16
'Notes       :
'Revisions   :
Public Function ConvertLocalToGMT(dtLocalDate As Date) As Date
    Dim lSecsDiff As Long
 
    'Get the GMT time diff
    lSecsDiff = GetLocalToGMTDifference()
    'Return the time in GMT
    ConvertLocalToGMT = DateAdd("s", -lSecsDiff, dtLocalDate)
End Function

'Purpose     :  Converts GMT time to local time.
'Inputs      :  dtLocalDate                 The GMT data time to return as local time.
'Outputs     :  Returns GMT as local time.
'Author      :  Andrew Baker
'Date        :  13/11/2002 10:16
'Notes       :
'Revisions   :
Public Function ConvertGMTToLocal(gmtTime As Date) As Date
    Dim Differerence As Long
 
    Differerence = GetLocalToGMTDifference()
    ConvertGMTToLocal = DateAdd("s", Differerence, gmtTime)
End Function

'Purpose     :  Returns the time lDiff between local and GMT (secs).
'Inputs      :  dtLocalDate                 The local data time to return as GMT.
'Outputs     :  Returns the local time in GMT.
'Author      :  Andrew Baker
'Date        :  13/11/2002 10:16
'Notes       :  A positive number indicates your ahead of GMT.
'Revisions   :
Public Function GetLocalToGMTDifference() As Long
    Const TIME_ZONE_ID_INVALID& = &HFFFFFFFF
    Const TIME_ZONE_ID_STANDARD& = 1
    Const TIME_ZONE_ID_UNKNOWN& = 0
    Const TIME_ZONE_ID_DAYLIGHT& = 2
 
    Dim tTimeZoneInf As TIME_ZONE_INFORMATION
    Dim lRet As Long
    Dim lDiff As Long
 
    'Get time zone info
    lRet = GetTimeZoneInformation(tTimeZoneInf)
 
    'Convert diff to secs
    lDiff = -tTimeZoneInf.Bias * 60
    GetLocalToGMTDifference = lDiff
 
    'Check if we are in daylight saving time.
    If lRet = TIME_ZONE_ID_DAYLIGHT& Then
        'In daylight savings, apply the bias
        If tTimeZoneInf.DaylightDate.wMonth <> 0 Then
            'if tTimeZoneInf.DaylightDate.wMonth = 0 then the daylight
            'saving time change doesn't occur
            GetLocalToGMTDifference = lDiff - tTimeZoneInf.DaylightBias * 60
        End If
    End If
End Function

Data Validation Using VBA

Please find the attachment

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

Example of Select Case in VBA

Dim rng As Range, totalsalary As Long

Sub calculatesalary()
Set rng = Application.InputBox("Select Range", "salary", Type:=8)
For Each cell In rng
        Select Case cell.Value
        Case Is <= 900
         totalsalary = cell.Value + (cell.Value * 0.1)
        Case 901 To 1000
         totalsalary = cell.Value + (cell.Value * 0.125)
        Case Is > 1000
        totalsalary = cell.Value + (cell.Value * 0.15)
        End Select
        cell.Offset(, 1) = totalsalary
Next
End Sub

Using Enumeration In VBA

VBA code to develop a function to calculate salary with allowance



Public Enum commission
grade1 = 100
grade2 = 125
grade3 = 150
End Enum

Function Calculatesalary(ByVal rng As Range) As Long
Dim salary, totalsalary As Long, myrng As Range

Set myrng = rng

salary = CLng(myrng.Value)

Select Case (salary <= 900)
Case True

    totalsalary = salary + salary * ((commission.grade1) / 1000)
 
Case Else
    Select Case (900 < salary <= 1000)
    Case True
    totalsalary = salary + salary * ((commission.grade2) / 1000)
    Case Else
        Select Case (1000 < salary)
        Case True
            totalsalary = salary + salary * ((commission.grade3) / 1000)
        End Select
    End Select

End Select

Calculatesalary = totalsalary


totalsalary = 0
End Function

For details read

http://www.cpearson.com/excel/Enums.aspx

Count of Vowels In A String USING VBA

Option Explicit
Dim i As Integer, j As Integer
Dim myval As String
Sub countofVowels()
myval = Application.InputBox("Enter a word", "Word", Type:=2)

For i = 1 To Len(myval)
If LCase(Mid(myval, i, 1)) Like "[a,e,i,o,u]" Then
j = j + 1
End If


Next
MsgBox "Total count of Vowels" & j
i = 0
j = 0
End Sub

Insert Multiple Row before Unique Value through VBA

Region	Product	Grand_Total
ANZ	Tech	159
ANZ	OFM	70
ANZ	OFM	70
TC	HCIL	41
TC	HCIL	297
ASEAN	Apps	80
ASEAN	Apps	587
ASEAN	Systems	350
ASEAN	Apps	34
MGI	ORC	600
MGI	ORC	658
MGI	ORC	750
DL	ORG	340
DL	ORG	123
DL	ORG	107
GC	Systems	161
GC	Apps	83
GC	Apps	83
HR	CI	611
HR	CI	113
HR	CI	596
IN	Tech	551
IN	Tech	832
IN	Tech	66
KR	Tech	275
KR	OFM	87
KR	OFM	81
MP	HCL	665
MP	HCL	579
HP	MPGC	662
HP	MPGC	672
HP	MPGC	319
HP	MPGC	772
HP	MPGC	129

For example  if you want to insert a row after every unique region here is code

Option Explicit
Dim mycoll As Collection, strrow As String, finalstrrow As String
Dim myrng As Range, rowcount As Long, cell, i As Integer
Sub insertRowafterUnique()
rowcount = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
Set mycoll = New Collection
Set myrng = ThisWorkbook.Sheets(1).Range("A2:A" & rowcount)
strrow = vbNullString
On Error Resume Next
    For Each cell In myrng
        mycoll.Add cell, CStr(cell)

    Next
 
    For i = 2 To rowcount
            If ThisWorkbook.Sheets(1).Range("A" & i) <> ThisWorkbook.Sheets(1).Range("A" & (i + 1)) Then
                strrow = strrow & (i + 1) & ":" & (i + 1) & ","
             
 
 
            End If
    Next
    finalstrrow = Left(strrow, Len(strrow) - 1)
    ThisWorkbook.Sheets(1).Range(finalstrrow).EntireRow.Insert
End Sub

Find vs Search

Find
- Case Sensitive
- Can't using Wildcard

Seach
- Not Case Sensitive
- Can Using Wildcard