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