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
30 Jun 2013
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
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
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
Labels:
VBA Tipes
Location:
Dubai - United Arab Emirates
9 Jun 2013
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
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
Subscribe to:
Posts (Atom)