Pages

30 Jun 2013

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

22 Jun 2013

Extracting Text from Alphanumeric Strings

=SUBSTITUTE( SUBSTITUTE( SUBSTITUTE( SUBSTITUTE( SUBSTITUTE( SUBSTITUTE( SUBSTITUTE( SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A1,"0",""),"1",""),"2",""), "3",""),"4",""),"5",""), "6",""),"7",""),"8",""),"9","")

Download Link

Extracting Numbers from Alphanumeric Strings

=1*MID(A1,MATCH(TRUE,ISNUMBER(1*MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)),0),COUNT(1*MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1))+SUM(--(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)=".")))

Download Link

21 Jun 2013

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

4 Jun 2013

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