Count Colored Cells through VBA

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

VBA Code for Autofilter with dynamic criteria

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



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

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

File to download:

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

CustomPercentile Function using VBA

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

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

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

Updating Master File Using VBA

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




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

Convert File Format in a Folder

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

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

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

            Else
                MsgBox "Folder not selected"
            End If

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

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