I have a list of hyperlinks in Column A. Some work, some don't. I'm looking to make a script that checks if they work, then removes the ones that don't. What I have is:
Sub UndoLink()
Dim rng As Range
Dim i As Long
Dim n As String
i = 2
While i <= 4730
Set rng = Range("A" & i)
n = Range("A" & i).Value
If Worksheet.Function.FileExist(rng) = False Then
rng.Hyperlinks.Delete
i = i + 1
Else: i = i + 1
End If
Wend
End Sub
Public Function FileExist(path As String) As Boolean
If Dir(path) <> vbNullString Then FileExist = True
End Function
I'm getting a function error when I refer to FileExist in the sub. To clarify, the hyperlinks are all within strings like "648242," underlined in blue. If the path doesn't exist, I want to remove the hyperlink and keep the string. Is this possible?
To remove hyperlink:
rng.Hyperlinks.Delete
Related
I've made a For Each loop that'll keep data depending upon some criteria's, but I do not know how to format it so if a cell in column A contain exactly 8 numeric digits, then it'll keep the row.
Example:
Cell A289 Contains: 04245468 ← Keep this row
Cell A978 Contains: 04513 ← Delete this row
So far I have the following by using the left function within my code:
Sub CleanUpSheet1()
Dim RowA As Range
'hides any popups
Application.DisplayAlerts = False
'Deletes all blanks up to row 15,0000
Range("a2:A15000").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For Each RowA In Range("A2:A" & ActiveSheet.UsedRange.Rows.Count)
If Left(RowA.Value, 5) <> "issue" And Right(RowA.Value, 4) <> "-000" And RowA.Value <> 0 Then
RowA.EntireRow.Delete
End If
Next
're-enables popups
Application.DisplayAlerts = True
End Sub
If it's just a matter of numbers you can transform the cell value into a string (RowA.Text or maybe Cstr(RowA.Value) and then test on the lenght :
if len(cstr(RowA.Value)) = 8 ???
(or len(RowA.Text))
Tell me if I havn't understood your question.
Had to reformat this a lot.
Sub CleanUpSelect1()
Dim RowA As Range
Dim cRng As Range
Dim iCounter As Long
Set RowA = Sheet1.Range("A2:A" & Sheets("Sheet1").UsedRange.Rows.Count)
iCounter = 1
Do
Set cRng = RowA(iCounter, 1) 'Loop rows
If CStr(cRng.Value2) = vbNullString Then
cRng.EntireRow.Delete
Else
If Not KeepRow(cRng.Value2) Then
cRng.EntireRow.Delete 'Delete row
Else
iCounter = iCounter + 1 'Advance
End If
End If
Loop While iCounter <= RowA.Rows.Count 'Stop after loop all rows
End Sub
Private Function KeepRow(RowValue As String) As Boolean
KeepRow = (RowValue Like "########" Or RowValue Like "issue#" Or RowValue Like "######-###")
End Function
But it works.
Manual - Select range, execute Sub
How it works - Sub saves all non-blank cells to finalArray that is ultimately displayed in the selected range
What's the problem - if range contains cells with hyperlinks created via insert-hyperlink, the hyperlinks disappear.
Sub RemoveBlanks()
'i,j - counters, k - offset
Dim finalArray() As Variant
ReDim finalArray(Selection.Rows.Count, 1)
k = 1
For i = 1 To Selection.Rows.Count
If Selection(i, 1) <> "" Then
finalArray(k, 1) = Selection(i, 1)
k = k + 1
End If
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
Selection.Clear
For i = 1 To k
Selection(i, 1).Value = finalArray(i, 1)
Next i
End Sub
This Code will loops through each cell in the selected range, checks if the cell has a hyperlink then temporarily grab and store the address that it’s pointing to re-apply the hyperlink
Option Explicit
Sub fixHyperlinks()
Dim rng As Range
Dim address As String
Application.ScreenUpdating = False
For Each rng In Selection
If rng.Hyperlinks.Count > 0 Then
address = rng.Hyperlinks(rng.Hyperlinks.Count).address
rng.Hyperlinks.Add Anchor:=rng, _
address:=address
End If
Next
Application.ScreenUpdating = True
End Sub
After you run this code, you should be able to set in your array the range without losing your links.
Conclusion : Run this code before you run your macro.
So I have found a way around the issue after lurking through internet and trying to save links in another array (fails). It works only if the value in the cell is the same as name of a sheet, yet it solves my issue so far.
Sub CreateLinks()
'i - counter, the title as i=1 is omitted. Code uses value stored in cell to
'transform it into a link.
Dim i As Integer
For i = 2 To Selection.Rows.Count
If Selection(i) <> "" Then
ActiveSheet.Hyperlinks.Add anchor:=Selection(i), _
address:="#'" & CStr(Selection(i)) & "'!A1", _
TextToDisplay:=CStr(Selection(i))
End If
Next i
End Sub
I have a series of addresses from which I need to extract postal codes.The data is very sloppily formatted (not separated, some with spacings some without etc..) meaning the only way I can think to extract the postcodes is to create a column to which is added only the values which contain Text and a Number as these are the only cells to contain the postal code.
The data is too messy to isolate exactly where the postcode lies but I would like something to return a result like above.
How could I return only cell O2 & P2 from the range K2:R2?
*Address here is made up
Though I believe that #DarrenBartrup-Cook has a better answer. This quick dirty little UDF will do it bassed on the mix of numbers and text like asked.
Function pcode(rng As Range)
Dim rngt As Range
Dim chr As String
Dim i As Integer
For Each rngt In rng
If Not IsNumeric(rngt) Then
For i = 1 To Len(rngt)
If IsNumeric(Mid(rngt, i, 1)) Then
pcode = Trim(pcode & " " & rngt.Value)
Exit For
End If
Next i
End If
Next rngt
End Function
Put this in a module attached to the workbook, NOT the worksheet code or ThisWorkbook code.
You would call it from the sheet with this formula:
=pcode(I5:P5)
For a VBA result you could use the code below.
In cell T2 enter =GetPostCode(K2:R2),
or in VBA you can use Debug.Print GetPostCode(Sheet1.Range("K2:N2"))
I can't remember where I got the pattern from, but can probably be improved.
Public Function GetPostCode(AddressRange As Range) As Variant
Dim rCell As Range
Dim sAddressString As String
For Each rCell In AddressRange
sAddressString = sAddressString & " " & rCell.Value
Next rCell
sAddressString = Trim(sAddressString)
GetPostCode = ValidatePostCode(sAddressString)
End Function
Public Function ValidatePostCode(strData As String) As Variant
Dim RE As Object, REMatches As Object
Dim UKPostCode As String
'Pattern could probably be improved.
UKPostCode = "(?:(?:A[BL]|B[ABDHLNRST]?|C[ABFHMORTVW]|D[ADEGHLNTY]|E[CHNX]?|F[KY]|G[LUY]?|" _
& "H[ADGPRSUX]|I[GMPV]|JE|K[ATWY]|L[ADELNSU]?|M[EKL]?|N[EGNPRW]?|O[LX]|P[AEHLOR]|R[GHM]|S[AEGKLMNOPRSTWY]?|" _
& "T[ADFNQRSW]|UB|W[ACDFNRSV]?|YO|ZE)\d(?:\d|[A-Z])? \d[A-Z]{2})"
Set RE = CreateObject("VBScript.RegExp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = UKPostCode
End With
Set REMatches = RE.Execute(strData)
If REMatches.Count = 0 Then
ValidatePostCode = CVErr(xlErrValue)
Else
ValidatePostCode = REMatches(0)
End If
End Function
Edit: I thought it wasn't working as it only return E17 3RU which is in Walthamstow, but HE17 3RU isn't a valid postcode (http://www.royalmail.com/find-a-postcode) so it found the valid one.
I know if I check the strikethrough property of Font like, for example range("C1").Font.Strikethrough I'll have True if all the cell is strikethrough and a False if it's not but checking it in a cell like this:
The result of the property is Null.
Now, knowing this, is there a way to recognize if just part of the content cell is "strikethrough" and then parse it so I could replace with other text?
I know I can check each character (checked out this example) if it has the property active but, how could I know which part of the text is strikethrough and then replacing that text with another one?
So I was thinking about how I would do this and I came up with the following function.
Function strkThr(t As Range) As String
Dim i As Long
Dim y As Boolean
Dim temp As String
y = False
temp = ""
For i = 1 To Len(t.Value)
If Not t.Characters(i, 1).Font.Strikethrough = y Then
temp = temp & "|"
If y Then
y = False
Else
y = True
End If
End If
If Not y Then
temp = temp & Mid(t, i, 1)
End If
Next
strkThr = temp
End Function
Sub replace()
Dim cel As Range
For Each cel In Range("A1:A100")
cel.Value = strkThr(cel)
cel.Value = replace(cel.Value, "||", YOURVALUE)
Next cel
End Sub
The function replaces each grouping of strike through text with "||". Then in the sub you would replace the "||" with the value wanted.
I have the following Public sub:
Public Sub HowToSort()
Dim i As Long, j As Long, h As Long, curCell As Range, cellBelow(1 To 10) As Variant
Dim sortOrder(1 To 10), colIsString(1 To 10) As Variant
For i = 1 To hdrCount
'Find location of a cell
Set curCell = Application.WorksheetFunction.Match(headRow(i), Range("a1:z1")) ' Eventually extend outwards?
cellBelow(i) = curCell.Offset(0, 1).Value
If IsNumeric(cellBelow(i)) = False Then
colIsString(i) = True
sortOrder(i) = Application.InputBox(prompt:="Alphabetical = 'True' or Reverse Alphabetical = 'False' sorting for " & headRow(i), Type:=4)
ElseIf IsNumeric(cellBelow(i)) = True Then
colIsString(i) = False
sortOrder(i) = Application.InputBox(prompt:="Ascending = True or Descending = False for " & headRow(i), Type:=4)
Else
MsgBox ("Program does not recognize value contained in column" & headRow(i))
End
End If
Next i
End Sub
Which uses a global variable named headRow, containing an array of strings of names of the header row at the top of the worksheet. I am trying to use the match function to find the address of the cell where the header is located:
Set curCell = Application.WorksheetFunction.Match(headRow(i), Range("a1:z1"))
cellBelow(i) = curCell.Offset(0, 1).Value
I then want to use this address, offset it downwards one cell to find what type of data is entered, this data will be entered in array colIsString. However, the .Match function is not working, citing a 'Type Mismatch' error. I do not know how this could be? From my previous research it appears that the .Match command takes in a range, then searches that range to match a cell value. I have tried several incarnations of the .Match command with no success. Your thoughts appreciated...
H3lue
Use Find() instead:
Set curCell = Range("a1:z1").Find(headRow(i), , xlValues, xlWhole)
If Not curCell Is Nothing Then
'found the header
cellBelow(i) = curCell.Offset(0, 1).Value
'etc etc
Else
MsgBox "Header '" & headRow(i) & "' not found!"
End If
sortOrder and colIsString will go out of scope as soon as your sub exits though...