Highlight Duplicates

Sub ColorDuplicates()
'Color duplicate items between Sheet1.columns A and Sheet2.Column A
    For i = 1 To Sheets("Sheet1").Range("A65536").End(xlUp).Row
         If Application.WorksheetFunction.CountIf(Sheets("Sheet2").Range("A:A"), Sheets("Sheet1").Range("A" & i)) = 1 Then
            With Sheets("Sheet1").Range("A" & i).Font
                .ColorIndex = 3
                .Bold = True
            End With
         Else
            With Sheets("Sheet1").Range("A" & i).Font
                .ColorIndex = 1
                .Bold = False
            End With
         End If
    Next i
    For i = 1 To Sheets("Sheet2").Range("A65536").End(xlUp).Row
         If Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("A:A"), Sheets("Sheet2").Range("A" & i)) = 1 Then
            With Sheets("Sheet2").Range("A" & i).Font
                .ColorIndex = 3
                .Bold = True
            End With
         Else
            With Sheets("Sheet2").Range("A" & i).Font
                .ColorIndex = 1
                .Bold = False
            End With
         End If
    Next i
End Sub

Download Link

VBA Code for Insert Row

Sub InsRow()

Dim lastrow As Long, r As Long

lastrow = ActiveSheet.UsedRange.Rows.Count

For r = lastrow To 3 Step -1

If Cells(r, 1).Value <> "" Then Rows(r).Insert

Next r

End Sub

Download Link

VBA Code for Image Insert in Excel

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Picture As Object
If Target.Cells.Count > 1 Then Exit Sub
With Target.Offset(0, 1)
    Set Picture = Nothing
    On Error Resume Next
    Set Picture = Sheets("SMW").Pictures.Insert(ActiveWorkbook.Path & "\" & Target.Value & ".jpg")
    Picture.Top = .Top
            Picture.Left = .Left
            Picture.ShapeRange.LockAspectRatio = msoFalse
            Picture.Placement = xlMoveAndSize
            Picture.ShapeRange.Width = 50
            Picture.ShapeRange.Height = 44
End With
End Sub

Remove the Space

Sub TrimALL()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim cell As Range
'Also Treat CHR 0160, as a space (CHR 032)
Selection.Replace What:=Chr(160), Replacement:=Chr(32), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
'Trim in Excel removes extra internal spaces, VBA does not
On Error Resume Next 'in case no text cells in selection
For Each cell In Intersect(Selection, _
Selection.SpecialCells(xlConstants, xlTextValues))
cell.Value = Application.Trim(cell.Value)
Next cell
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Delete Blank Rows

Sub DeleteBlankRows1()
'Deletes the entire row within the selection if the ENTIRE row contains no data.
'We use Long in case they have over 32,767 rows selected.
Dim i As Long
 'We turn off calculation and screenupdating to speed up the macro.
 With Application
  .Calculation = xlCalculationManual
  .ScreenUpdating = False
  'We work backwards because we are deleting rows.
 For i = Selection.Rows.Count To 1 Step -1
  If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
   Selection.Rows(i).EntireRow.Delete
  End If
 Next i
 .Calculation = xlCalculationAutomatic
 .ScreenUpdating = True
 End With
End Sub

Avoid Scientific (Exponential) Notation

When we enter or paste the long numbers in cells, it’s automatically changed into scientific mode like 1.23E+10. It can be avoid with the help of below codes,

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count = 1 Then
Target.NumberFormat = "0"
Else
Call Multipaste
End If
End Sub

Sub Multipaste()
Dim mycell As Range
For Each mycell In Selection.Cells
mycell.NumberFormat = "0"
Next
End Sub

Listbox ADODB Connection

VBA codes for bring the access database into list-box when userform get initialize.
Private Sub UserForm_Initialize()
On Error GoTo UserForm_Initialize_Err
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "/DATABASE.mdb"
rst.Open "SELECT DISTINCT [Field_Name] FROM Table_Name ORDER BY [ Field_Name]", _
cnn, adOpenStatic
rst.MoveFirst
With Me.ListBox1
.Clear
Do
.AddItem rst![ Field_Name]
rst.MoveNext
Loop Until rst.EOF
End With
UserForm_Initialize_Exit:
On Error Resume Next
cnn.Close
rst.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
UserForm_Initialize_Err:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
Resume UserForm_Initialize_Exit
End Sub
Before running this macro you check ADO(Microsoft ActiveX Data Object Library x.x) at the VBEditor Tool →　Reference.


(winXP Pro & Excel2000)

Bold/Color

Make bold and change the color of the first 5 characters of text in a cell.

Sub FiveChrBoldColor()

Dim mycell As Range

For Each mycell In Selection.Cells

mycell.Characters(Start:=1, Length:=5).Font.FontStyle = "Bold"

mycell.Characters(Start:=1, Length:=5).Font.Color = -16776961

Next

End Sub

Removing Special Characters

Using below codes for removing specific set of characters which also includes  *,?~@#$%^&*()_+{}[]":;'<,>

Function ValidateString(strInput As String) As String
Dim strInvalidChars As String
Dim i As Long
strInvalidChars = "*,?~@#$%^&()_+{}[]:;<>" & "'" & """"
For i = 1 To Len(strInvalidChars)
strInput = Replace$(strInput, Mid$(strInvalidChars, i, 1), "")
Next
ValidateString = strInput
End Function