Sorted List By Array Function :

If you want to Sort Your List By Function , You can use this Array Function ,



Option Base 1
Option Compare Text
Function SortedList(rng As Range) As Variant
        Dim arr() As Variant
        Dim rw, cl As Double
        r = rng.Rows.Count
        cl = 1
        ReDim arr(r, cl)
                arr = rng
                For i = 1 To r
                    For j = 1 To r - i
                        If arr(j, 1) > arr(j + 1, 1) Then
                            temp = arr(j, 1)
                                arr(j, 1) = arr(j + 1, 1)
                                arr(j + 1, 1) = temp
                            End If
                    Next
                Next
            SortedList = arr
End Function

Check if the Table is Exist or Not In Access DataBase

If you want to Check the particular table is exist in Access Database or Not  You Can use this Function :



Option Compare Text
Sub IsExist()
Dim cn As ADODB.Connection
    Dim rst As Recordset
    Dim MyConn As String
    MyConn = "D:\MyDataBase.accdb"
    Set cn = New ADODB.Connection


    With cn
    .Provider = "Microsoft.ace.Oledb.12.0"
    .Open MyConn
    End With
            
        Set rst = cn.OpenSchema(adSchemaTables)
        rst.MoveFirst
        Do Until rst.EOF
                If rst!Table_Name = "MyTable1" Then
                MsgBox "Table Exist "
                Exit Do
                End If
                rst.MoveNext
        Loop
        
        rst.Close
        cn.Close
End Sub

Making Different Workbook WithOut Formulas :

If you have a workbook which contain Lot of Function and you want to copy all that values in another Workbook You can use this Code :



Sub GetALlSheet()
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = ActiveWorkbook
        Application.Workbooks.Add
        For Each sh In wb.Sheets
            sh.Copy ActiveWorkbook.Sheets(1)
                ActiveSheet.Cells.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                Application.CutCopyMode = False
        Next
        ActiveWorkbook.SaveAs "D:\MyWorkbook"
        ActiveWorkbook.Close
End Sub

Get All Worksheets Name by Array Function :

If You want to Get all Existing worksheet in a Workbook you can use this Array Function :
Suppose you have 100 Worksheet in a Workbook and You want all sheet name in a sheet then select any 100 cells Type this Function name and press Shift+Ctrl+Enter , You will get all sheet Names :


Function Sheetname() As Variant
Application.Volatile
Dim Sheet() As Variant
Dim r As Integer
Dim c As Integer
Dim i As Integer

With Application.Caller
        r = .Rows.Count
        c = .Columns.Count
End With

ReDim Sheet(1 To r, 1 To c)
    i = 1
    For j = 1 To r
        For k = 1 To c
        If i > Sheets.Count Then Exit For
        Sheet(j, k) = Sheets(i).Name
        i = i + 1
    Next
Next

For j = 1 To r
    For k = 1 To c
        If Sheet(j, k) = 0 Then Sheet(j, k) = ""
    Next
Next
Sheetname = Sheet
End Function

Hiding Rows :

If you want to Hide Rows on Excel Worksheet if any cell value match with Your Criteria in Selection You can use this Code :



Option Compare Text
Sub HidingMatchingRows()
Application.ScreenUpdating = False
Dim rng As Range
If TypeName(Selection) = "Range" Then
Set rng = Selection
Else
MsgBox "Select Some Range", vbInformation
Exit Sub
End If
        
        For r = 1 To rng.Rows.Count
            For c = 1 To rng.Columns.Count
                If rng.Cells(r, c).Value = "Rajan" Then rng.Cells(r, c).EntireRow.Hidden = True
                Next
        Next
Application.ScreenUpdating = True
End Sub

Compiling Workbooks :-

If You want to Compile Many Worbooks data in a single Workbook you can use this Code :

Sub Compile()

On Error GoTo Err_Clear:

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Dim Fso As New Scripting.FileSystemObject

Dim Path As String

Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Pick Downloaded Bills"

Application.FileDialog(msoFileDialogFolderPicker).Show

Path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If Path = "" Then Exit Sub

Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Save Compiled File"

CompilePath = Application.FileDialog(msoFileDialogFolderPicker).Show

compiledPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If compiledPath = "" Then Exit Sub

   

   

Dim Counter

Dim File As File

Dim FOlder As FOlder

Dim wb As Workbook

Dim ws As Worksheet

Dim AcWb As Workbook

Set AcWb = ActiveWorkbook

             ActiveWorkbook.Sheets.Add

             ActiveSheet.Name = "Index"

Set FOlder = Fso.GetFolder(Path)

        For Each File In FOlder.Files

             Counter = Counter + 1

             Set wb = Workbooks.Open(Path & File.Name)

               

                            If Application.Ready = True Then

                                

                                 wb.Sheets("Index").Activate

                                 ActiveSheet.UsedRange.Copy

                                  AcWb.Sheets("Index").Activate

                                  Range("A1000000").End(xlUp).Select

                                  ActiveSheet.Paste

                                 Application.CutCopyMode = False

                                 wb.Close

                            End If

        Next

If Counter > 0 Then

AcWb.SaveAs compiledPath & "Compiled", xlExcel12

AcWb.Close

End If

Err_Clear:

Err.Clear

Resume Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

        If Counter < 1 Then

        MsgBox "No File Found For Compile", vbInformation

        Else

        MsgBox Counter & " File Has been Compiled, Please Find your File at" & vbCrLf & compiledPath, vbInformation

        End If

       

End Sub

Delete Comments :

If You want to Delete All Comments From a Worksheet , Try this :


Sub delComment()
Dim cmt As Comment
For Each cmt In ActiveSheet.Comments
cmt.Delete
Next cmt
End Sub

Toggle Comment Box

IF you want to toggle Comment box to  Visible/Hide ,you can use this Code :


Sub ToggleComments()
On Error Resume Next
Dim count As Integer
count = ActiveSheet.Comments.count
If count = 0 Then MsgBox "There is no comment"
    If Application.DisplayCommentIndicator = xlCommentAndIndicator Then
        Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    Else
        Application.DisplayCommentIndicator = xlCommentAndIndicator
    End If
End Sub

Count Comments On A Worksheet

How to Count the comment on a Worksheet :


Sub CountComment()
On Error Resume Next
Dim cmt As Comment
Dim count As Integer
count = 0
For Each cmt In ActiveSheet.Comments
count = count + 1
Next cmt
If count = 0 Then
MsgBox "There is no Comment in Active Worksheet"
Else
MsgBox "Total Comment in active sheet = " & count
End If
End Sub

Concatenation of All String in Selection

if you want to Concatenate Some Data you can use this Code :

Sub ConcateAll()

    Dim Resultcell As Range

    Dim rng As Range

    Dim cell As Range

    Dim resultString As String

    Set rng = Application.InputBox("Please select A Range For Input ", , , , , , , 8)

    Set Resultcell = Application.InputBox("Please select A Range For Out ", , , , , , , 8)

    resultString = ""

    For Each cell In rng

        resultString = resultString & " " & cell.Value

    Next

    Resultcell = resultString

End Sub

Get Unique List : Another Method

if You want to get Unique list from a Range ,You ca use this array Function :

Function GetUniqueList(rng As Range) As Variant

On Error Resume Next
 
    Dim Arr() As Variant
    Dim cell As Range
    Dim r, c As Integer
    Dim i, j As Integer
    i = 0: j = 0
   
    With Application.Caller
    r = .Rows.Count
    c = .Columns.Count
    End With
    ReDim Arr(r - 1, c - 1)

    For Each cell In rng
    If WorksheetFunction.CountIf(rng.Cells(1, 1).Resize(cell.Row, 1), cell.Value) = 1 Then
        Arr(i, j) = cell.Value
        If j = c Then j = j + 1
        i = i + 1
        End If
       
     For k = i To UBound(Arr())
     Arr(k, 0) = ""
     Next
    Next
    GetUniqueList = Arr
End Function

Matching Data With in 2 Range :

if You want to Match the Data Between Two Range, You can use this Macro : 

Both Range must be Same,

Sub matchValue()

On Error resume Next

Application.ScreenUpdating = False

Dim F_range As Range

Dim S_range As Range

Set F_range = Application.InputBox("Please Select 1st Range", , , , , , , 8)

Set S_range = Application.InputBox("Please Select 2nd Range", , , , , , , 8)

Dim r As Integer

Dim c As Integer

r = F_range.Rows.Count

c = F_range.Columns.Count

Dim cc As Integer

Dim rc As Integer

For cc = 1 To c

For rc = 1 To r

'For Each cell In F_range.Cells

If F_range.Cells(rc, cc).Value = S_range.Cells(rc, cc).Value Then

Else

F_range.Cells(rc, cc).Font.Bold = True

F_range.Cells(rc, cc).Color = 2

F_range.Cells(rc, cc).Interior.ColorIndex = 31

S_range.Cells(rc, cc).Font.Bold = True

S_range.Cells(rc, cc).Interior.ColorIndex = 31

End If

Next rc

Next cc

Application.ScreenUpdating = True

Range("A1").Select

End Sub

Extract Unique List :

if you want to Extract Unique Value From a List , you can use this UDF :

Function UniqueList(rng As Range, Pos As Long) As String Dim List() As String

    Dim cell As Range

    Dim i As Long

    Dim t As Long

    i = 0

ReDim List(rng.Cells.Count) As String

For Each cell In rng

flag = 0

                    For t = LBound(List) To UBound(List)

                       If cell.Value = List(t) Then

                 

                        flag = 1

                        Exit For

                        End If

                        Next

                           

                            If flag = 0 Then

                            List(i) = cell.Value

                            i = i + 1

                            End If

Next

UniqueList = List(Pos)

End Function

Adding Custom Menus In Excel :

If You want to add Custom Manus in Excel you can Write a program like this :



Private Sub Workbook_Open()
If Application.Version >= 12 Then
On Error Resume Next
Dim Cbar As CommandBar


Set Cbar = Application.CommandBars.Add
With Cbar
.Name = "EB_Pro(Version.0.1)"
.Visible = True
.Position = msoBarTop
End With


With Cbar.Controls.Add(msoControlButton)
.Caption = "&DownLoadBill"
.Style = msoButtonCaption
.OnAction = "Module1.DownloadBills"
.Visible = True
.BeginGroup = True
End With




With Cbar.Controls.Add(msoControlButton)
.Caption = "&DownloadPayMent" & vbCrLf & "History"
.Style = msoButtonCaption
.OnAction = "PaymentHistory.DownloadHistory"
.Visible = True
.BeginGroup = True
End With

End Sub

Vlookup Comments :

if you want to Get Comment with Lookup Value in Result Cells , You can use this Code :

Sub VlookupByCodes()

Dim ResultRange As Range

Dim SearchRange As Range

Dim ColNum As Integer

Dim LookUpValue As Range

Dim cellResult As Range

Dim CellSearch As Range

Dim i As Integer

        Set ResultRange = Application.InputBox("Select the Range Where You want Output", , , , , , , 8)

        Set LookUpValue = Application.InputBox("Select the Range of searchable Value", , , , , , , 8)

        Set SearchRange = Application.InputBox("Select the Range to Search Value", , , , , , , 8)

        ColNum = Application.InputBox("Give Colnum")

        i = 1

               

                    For Each cellResult In ResultRange

                            For Each CellSearch In SearchRange

                                    If CellSearch.Value = LookUpValue.Cells(i, 1).Value Then

                                        cellResult.Value = CellSearch.Offset(0, ColNum).Value

                                                If hasComment(CellSearch.Offset(0, ColNum)) = True Then

                                                    cellResult.AddComment

                                                    cellResult.Comment.Visible = True

                                                    cellResult.Comment.Text CellSearch.Offset(0, ColNum).Comment.Text

                                                End If

                                        i = i + 1

                                        Exit For

                                    End If

                            Next

                    Next

Set ResultRange = Nothing

Set LookUpValue = Nothing

Set SearchRange = Nothing

Set cellResult = Nothing

Set CellSearch = Nothing

       

End Sub

Private Function hasComment(cell As Range) As Boolean

On Error GoTo err:

If cell.Comment.Text <> "" Then

hasComment = True

Else

hasComment = False

End If

err:

If err.Number <> 0 Then

hasComment = False

End If

End Function