Return The Last Repeated Record

If the records are repeated, then the late repeated record will be reported only.

Sub distinct_value_lower()

Dim pointers As String
pointers = Range("a1").Value
'Debug.Print "1:" & pointers

For x = 2 To 36
If Range("A" & x).Value = pointers Then
pointers = Range("A" & x).Value
Else
Range("B" & x - 1).Value = pointers
pointers = Range("A" & x).Value
End If
Next
End Sub

Find email and copy to a separate cell

The following sub can help to copy the email in a row and paste to a separator. It is usefull when the email addresses occurred randomly in the Excel.

Sub Find_email()

For i = 2 To 2357
Range("A" & i, "AS" & i).Select
Cells.Find(What:="@", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Select

Selection.Copy
Range("AT" & i).Select
ActiveSheet.Paste
Next

End Sub

Grab Data Using Excel

Dim a(3)
a(0) = "http://www.jewellery-hk.org/big5/cfullmember.php?eng_coname=A-1%20Jewelry%20Manufactory%20Limited"
a(1) = "http://www.jewellery-hk.org/big5/cfullmember.php?eng_coname=Aaron%20Shum%20Jewelry%20Limited"
a(2) = "http://www.jewellery-hk.org/big5/cfullmember.php?eng_coname=Abba%20Jewellery%20%28Mfg%29%20Limited"

Dim i As Integer
Dim x As Integer
x = 1
For i = 0 To 3

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & a(i) & "" _
, Destination:=Range("A" & x))
.Name = "Jewellery" & i
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "8"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=Ture
End With

x = x + 12
Next

Data Horizontal to Vertical

Dim x As Integer
x = 1

For i = 1 To 2748

'Range("B1:B12").Select
rangeA = "B" & i
rangeB = "B" & i + 11
Range(rangeA, rangeB).Select
Selection.Copy
Range("D" & x).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

i = i + 11
x = x + 1
Next
End Sub

HTML to ASCII Code

http://onlinetools.org/tools/htmlizerdata/index.php

VBscript While Loop

i=0

do while i < 10

document.write(i & "<br />")

i=i+1

loop

VBscript Foreach Loop

dim names(2)
names(0) = "Tove"
names(1) = "Jani"
names(2) = "Hege"

for each x in names
document.write(x & "
")
next

VBscript For Loop

for i = 0 to 5
document.write("The number is " & i & "
")
next

VBscript Array

dim a
a=Array(5,10,15,20)
document.write(a(3))

Output:

20

================

Dim myArray(3)
myArray(0) = "Clean Underwear"
myArray(1) = "Vacuum Cleaner"
myArray(2) = "New Computer"
myArray(3) = "Talking Bass"
document.write(myArray(0))

Extract Hyperlink in Excel

EXTRACT HYPERLINK IN EXCEL



Function HyperLinkText(pRange As Range) As String

Dim ST1 As String
Dim ST2 As String
Dim LPath As String
Dim ST1Local As String

If pRange.Hyperlinks.Count = 0 Then
Exit Function
End If

LPath = ThisWorkbook.FullName

ST1 = pRange.Hyperlinks(1).Address
ST2 = pRange.Hyperlinks(1).SubAddress

If Mid(ST1, 1, 15) = "..\..\..\..\..\" Then
ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15)
ElseIf Mid(ST1, 1, 12) = "..\..\..\..\" Then
ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12)
ElseIf Mid(ST1, 1, 9) = "..\..\..\" Then
ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9)
ElseIf Mid(ST1, 1, 6) = "..\..\" Then
ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6)
ElseIf Mid(ST1, 1, 3) = "..\" Then
ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3)
Else
ST1Local = ST1
End If

If ST2 <> "" Then
ST1Local = "[" & ST1Local & "]" & ST2
End If

HyperLinkText = ST1Local

End Function

Function ReturnPath(pAppPath As String, pCount As Integer) As String

Dim LPos As Integer
Dim LTotal As Integer
Dim LLength As Integer

LTotal = 0
LLength = Len(pAppPath)

Do Until LTotal = pCount + 1
If Mid(pAppPath, LLength, 1) = "\" Then
LTotal = LTotal + 1
End If
LLength = LLength - 1
Loop

ReturnPath = Mid(pAppPath, 1, LLength)

End Function


USAGE :
=HyperLinkText(A1)