Search This Blog

Friday 27 January 2012

CODE TO PASTE NON BLANK CELLS ONLY


'Selection column A and run the below code in module

Sub PasteNotBlanks()
If Selection.Columns.Count > 1 Then
msgbox "Please selection one column."
Else
Selection.SpecialCells(xlCellTypeConstants).Copy Destination:=Range("B1")
End If
End Sub

CODE TO SELECT ALL DATA ON A WORKSHEET


Sub select_all()
Application.ScreenUpdating = False
Dim mylastrow As Long
Dim mylastcol As Long
Dim mylastcell, myrange
Range("A1").Select
On Error Resume Next
mylastrow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
mylastcol = Cells.Find("*", [a1], , , xlByColumns, xlPrevious).Column
mylastcell = Cells(mylastrow, mylastcol).Address
myrange = "a1:" & mylastcell
Application.ScreenUpdating = True
Range(myrange).Select
End Sub

CODE FOR CHANGING THE NAME OF COMMAND BUTTON

Private Sub CommandButton1_Click()
If CommandButton1.Caption = "Start" Then
CommandButton1.Caption = "End"
Sheet1.Range("A1").Value = Format(Time, "long time")
ElseIf CommandButton1.Caption = "End" Then
CommandButton2.Caption = "Start"
Sheet1.Range("B1").Value = Format(Time, "long time")
End If
End Sub

CODE FOR HIGHLIGHTING DUPLICATE VALUES

Sub highlight_duplicates()

Dim i, j As Integer
Dim mycheck, rng
Application.ScreenUpdating = False
rng = Selection.Rows.Count
For i = rng To 1 Step -1
mycheck = ActiveCell
ActiveCell.Offset(1, 0).Select
For j = 1 To i
If ActiveCell = mycheck Then
Selection.Font.Bold = True
Selection.Font.ColorIndex = 3
End If
ActiveCell.Offset(1, 0).Select
Next j
ActiveCell.Offset(-i, 0).Select
Next i
Application.ScreenUpdating = True
End Sub

TO FIND OUT THE ADDRESS OF BLANK CELLS WITH A MSGBOX


Sub MsgBoxBlankCells()
  MsgBox Range("A:E").SpecialCells(xlCellTypeBlanks).Address(0, 0)
End Sub

SPLIT DATA FROM ONE SHEET TO MULTIPLE SHEETS

Sub parse_data()

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

vcol = 2        'CHANGE THE COLUMN NUMBER AS PER YOUR NEED

Set ws = Sheets("Data")        'CHANGE THE SHEET NAME AS PER YOUR NEED

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

title = "A1:Z1"             'CHANGE THE TITLE ROW AS PER YOUR NEED
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count

ws.Cells(1, icol) = "Unique"

For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))

ws.Columns(icol).Clear

For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next

ws.AutoFilterMode = False
ws.Activate

End Sub

CODE FOR GETTING THE FILE PATH OF ALL THE FILES IN A FOLDER INTO YOUR EXCELSHEET



Sub get_file_path()
    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$
    Sheets(1).Select
    InitialFoldr$ = "D:\"       '<<< Startup folder to begin searching from
    Range("A2").Select
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr$
        .Show
        If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)
            Do While xFname$ <> ""
                ActiveCell.Offset(xRow) = xDirect$ & xFname$
                xRow = xRow + 1
                xFname$ = Dir
            Loop
        End If
    End With
    End Sub

CODE FOR HIGHLIGHTING DUPLICATE VALUES IN DIFFERENT COLORS

Sub Highlight_Duplicate_Entry()
    Dim cel As Variant
    Dim myrng As Range
    Dim clr As Long
    Set myrng = Range("A2:A" & Range("A65536").End(xlUp).Row)
    myrng.Interior.ColorIndex = xlNone
    clr = 3
    For Each cel In myrng
        If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
            If WorksheetFunction.CountIf(Range("A2:A" & cel.Row), cel) = 1 Then
                cel.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
            End If
        End If
    Next
End Sub