I've got a CSV with 27,000 records with some last names having brackets and text in them such as Harvey (MD5), i've managed to work it so it will do it when targeted at a single cell to delete the text inside the brackets and the brackets themselves but when i try to loop it i get a [RUNTIME ERROR 5] -invalid procedure call or argument....
This is my loop
Sub test()
Application.ScreenUpdating = False
Dim myCell As Range
Dim myRange As Range
Dim cellvalue As String
Set myRange = Range("D1:D27168")
For Each myCell In myRange
cellvalue = myCell.Value
openingParen = InStr(cellvalue, "(")
closingParen = InStr(cellvalue, ")")
enclosedValue = Mid(cellvalue, openingParen + 1, closingParen - openingParen - 1)
Cells.Find(What:=enclosedValue, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Replace What:=enclosedValue, Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next myCell
Application.ScreenUpdating = True
End Sub
is there something I'm doing wrong, i've removed the bracket find and replace code to keep it short.
feel like something is a miss
You probably get the error because of openingParen and closingParen values. If Mid gets wrong integer inputs (such as Mid("text", 1, 1 - 3) or Mid("text", -10, 5)) it fails with an error 5.What I recommend is to test your InStr results before calling Mid and/or add Error Handling, something like (pseudo-code, not tested) :
Option Explicit
Option Base 0
(.....)
On Error Resume Next
newRes = Mid("mytext", iFrom, iTo)
If (Err.Number = 0) Then
'do what you planned here
Else
'handle error
Call MsgBox(Err.Message & CStr(iFrom) & ", " & CStr(iTo))
End If
(...)
On Error Goto 0 'turn off error sinking
Related
I am trying simple replace to delete the brackets and text within it but it's not working.
Please help. My code is:
Dim r As Integer
For r = 2 To 30
Cells(r, 3) = Replace(Cells(r, 3), "(*)", "")
MsgBox Cells(r, 3)
Next
The Ordinary replace function doesn't take wildcards * - but for some reason, Range.Replace does.
Dim rng1 as Range
Set rng1 = Range(Cells(2,3), Cells(30,3))
rng1.Replace What:= "(*)", Replacement:= "", LookAt:= xlPart, SearchOrder:=xlByRows, MatchCase:= False, SearchFormat:=False, ReplaceFormat:=False
(Obviously you probably won't need to use all of those named parameters...)
Use Range.Replace function and make the replacement at once:
Sub testReplace()
Dim rngR As Range
Set rngR = Range("C2:C30")
rngR.Replace "(*)", ""
End Sub
I am new to writing macros and have search everywhere for a solution to my problem with no luck, so I'm hoping for some help here.
I have an Excel spreadsheet containing multiple calculation which are automated. This means a big part of the spreadsheet is locked for other users who only need to do the calculations. Basically what I want is to have this spreadsheet in two different languages. So using a macro I want to change all the text content in my spreadsheet from one language to another. Since i only want one spreadsheet (because I keep updating it and adding new calculations to it) I thought a macro with a button to switch between the 2 language was the best solution.
Here is my problem. I used find and replace to replace each word which is working fine.
Sub Rename_EN()
'
ActiveSheet.Unprotect
Cells.Select
Selection.Replace What:="rød", Replacement:="red", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="grøn", Replacement:="green", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="blå", Replacement:="blue", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="Flt-tag", Replacement:="FLT-roof", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
But the text also have technical terms, fx. I want F_(LT-tag) to be replaced with F_(LT-roof), but with (LT-roof) as a sub-scripted text.
I searched for a long time and came to the conclusion that it is not possible to simple subscript the text in a code. (if it is, then please feel free to tell me how :)) I then found this code that can change specific characters to subscript and superscript:
Sub Super_Sub()
Dim NumSub
Dim NumSuper
Dim SubL
Dim SubR
Dim SuperL
Dim SuperR
Dim CheckSub
Dim CounterSub
Dim CheckSuper
Dim CounterSuper
Dim Cell
'
CheckSub = True
CounterSub = 0
CheckSuper = True
CounterSuper = 0
Cell = ActiveCell
'
NumSub = Len(Cell) - Len(Application.WorksheetFunction.Substitute(Cell, "[", ""))
NumSuper = Len(Cell) - Len(Application.WorksheetFunction.Substitute(Cell, "{", ""))
'
If Len(Cell) = 0 Then Exit Sub
If IsError(Application.Find("[", ActiveCell, 1)) = False Then
Do
Do While CounterSub <= 1000
SubL = Application.Find("[", ActiveCell, 1)
SubR = Application.Find("]", ActiveCell, 1)
ActiveCell.Characters(SubL, 1).Delete
ActiveCell.Characters(SubR - 1, 1).Delete
ActiveCell.Characters(SubL, SubR - SubL - 1).Font.Subscript = True
CounterSub = CounterSub + 1
If CounterSub = NumSub Then
CheckSub = False
Exit Do
End If
Loop
Loop Until CheckSub = False
End If
'
'
If IsError(Application.Find("{", ActiveCell, 1)) = False Then
Do
Do While CounterSuper <= 1000
SuperL = Application.Find("{", ActiveCell, 1)
SuperR = Application.Find("}", ActiveCell, 1)
ActiveCell.Characters(SuperL, 1).Delete
ActiveCell.Characters(SuperR - 1, 1).Delete
ActiveCell.Characters(SuperL, SuperR - SuperL - 1).Font.Superscript = True
CounterSuper = CounterSuper + 1
If CounterSuper = NumSuper Then
CheckSuper = False
Exit Do
End If
Loop
Loop Until CheckSuper = False
End If
'
End Sub
So I wanted to make a button that would run the macros in a specific order. The problem here is, that I need to select the cells with { and [ to run the code.
Can I rewrite this code to be used for a whole spreadsheet? I again searched for a solution and couldn't find one, so I tried to make yet another macro to run before this, that finds and selects all cells in a sheets containing { and [. Again I hit a wall since I can't get the it to select multiple cells in a whole sheet.
One way I can think of doing it is to have a second hidden sheet containing the replacement text in the relevant cells. You can then use FIND to find all cells containing a value, check it doesn't hold a formula and swap the value with that held in the second sheet.
Sub Test()
Dim firstAddress As String
Dim rCell As Range
Dim sValue As String
Dim MainSheet As Worksheet
Dim SecondSheet As Worksheet
'MainSheet contains your formula & text.
'SecondSheet only contains values in the text cells.
With ThisWorkbook
Set MainSheet = .Worksheets("Sheet1")
Set SecondSheet = .Worksheets("Sheet2")
End With
Set rCell = MainSheet.Cells.Find("*", , xlValues, xlWhole, , xlNext, True)
If Not rCell Is Nothing Then
firstAddress = rCell.Address
Do
'If the cell doesn't contain a formula swap its value with
'the value held in the second sheet.
If Not rCell.HasFormula Then
sValue = rCell.Value
rCell.Value = SecondSheet.Range(rCell.Address).Value
SecondSheet.Range(rCell.Address).Value = sValue
End If
Set rCell = MainSheet.Cells.FindNext(rCell)
Loop While rCell.Address <> firstAddress
End If
End Sub
I am trying to display an error message of invalid number if an element is not found from one sheet to the next.
Sub info()
Dim dehyp As Long
Dim rng As Range
Dim wrong As String
wrong = "False"
dehyp = Replace(Range("A5").Value, "-", "")
Sheets("Gov").Select
Set rng = Sheets("Gov").Columns(1).Find(What:=dehyp, LookIn:=xlFormulas,
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
On Error Resume Next
Set wrong = "True"
If wrong = "True" Then
Sheets("Total usage").Select
MsgBox ("Invalid Number")
Else
rng.Offset(0, 1).Select
Selection.Copy
Sheets("Total usage").Select
Range("B5").Select
ActiveSheet.Paste
'this part works without the else and the error stuff
End If
End Sub
I have defined the dimensions of the variables and set the initial variable wrong to be false. I am getting an compilation error that says an object is required. So my question is why is that happening and what could I do to fix the error?
Standing all the comments, I guess you may be after this code:
Option Explicit
Sub info()
Dim dehyp As Long
Dim rng As Range
dehyp = Replace(Range("A5").Value, "-", "")
Set rng = Sheets("Gov").Columns(1).Find(What:=dehyp, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If rng Is Nothing Then
MsgBox ("Invalid Number")
Else
rng.Offset(0, 1).Copy Destination:=Sheets("Total usage").Range("B5")
End If
End Sub
So the title says it all. I've written this short code to try and take website URL's and remove unwanted aspects to make them all nice and pretty for clients. However, for some reason this sort of template I've been using a lot has failed me this time around by only giving the royal treatment to B2 the only cell directly called out in the code. I debugs fine and runs fine just not accomplishing what I'd like it to. Not having an error makes this hard to discern what the problem is. If any of you can see whats going on here please do let me know.
Sub Website()
Application.ScreenUpdating = False
Range("B2").Select
Dim TitleString As Range, cel As Range
Set TitleString = ActiveCell
Do Until IsEmpty(ActiveCell)
For Each cel In TitleString
If InStr(1, cel.Value, "https://") > 0 Then '
Selection.Replace What:="https://", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
If InStr(1, cel.Value, "http://") > 0 Then
Selection.Replace What:="http://", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
If InStr(1, cel.Value, "/") > 0 Then
Selection.Replace What:="/*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
If InStr(1, cel.Value, "www.") > 0 Then
Exit For
ElseIf InStr(1, cel.Value, "www.") = 0 Then
ActiveCell.Value = "www." & ActiveCell.Value
Exit For
End If
Next cel
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub
Anytime one uses Select it forces vba to slow down.
This avoids select as well as loops.
Sub Website()
Dim rng As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set rng = ws.Range(ws.Cells(2, 2), ws.Cells(ws.Rows.Count, 2).End(xlUp))
rng.Replace "https://", ""
rng.Replace "http://", ""
rng.Replace "/*", ""
rng.Replace "www.", ""
rng.Value = Evaluate("INDEX(""www.""&" & rng.Address & ",)")
Application.ScreenUpdating = True
End Sub
Before:
After:
This looks like it's failing because you set the TitleString range outside of the do loop so there's only one cell to loop through. You can simplify this a lot by removing the do loop entirely. Instead declare the cells you want to loop through as a range initially.
Sub Website()
Application.ScreenUpdating = False
Range("B2").Select
Dim rng As Range
Dim cel As Range
Set rng = Range(Selection, Selection.End(xlDown))
For Each cel In rng
' IF STATEMENTS
Next
Application.Screenupdating = True
End Sub
I have a worksheet with more than 200 cells.
Each cell contains a formula as below:
=AVERAGE('worksheetname'!range)
I want to run a macro that changes the formula to following formula:
=IFERROR(AVERAGE('worksheetname'!range),100%)
I have worked out that I can change =AVERAGE into for example &AVERAGE and than search & replace &AVERAGE with &IFERROR. It will allow me to search for cells which contains &IFERROR and add missing parenthesis at the end of formula )
I want to build a macro but have few problems:
how to search & replace it all once for each cell
macro gives me a mismatch error
below is a code for my macro:
Sub aaaa()
'
' IFERROR Macro
'
'
Dim myRange As Range
Dim myCell As Range
Dim i As Integer
Set myRange = Range("E4:BB120")
Sheets("Zones").Select
Cells.Replace What:="=AVERAGE(", Replacement:="&IFERROR(AVERAGE(", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
For Each myCell In myRange
If myCell Like "*&IFERROR*" Then
myCell.Select
i = 1
Do While i < 2
Selection.Replace What:=")", Replacement:="),100%)", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
i = i + 1
Loop
End If
Next myCell
Cells.Replace What:="&IFERROR(AVERAGE(", Replacement:="=IFERROR(AVERAGE(", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
You might find it easier to do the replacement "manually" in code instead of using Replace :
Sub aaaa()
Dim myRange As Range
Dim c As Range
Dim f As String, i As Long
On Error Resume Next
Set myRange = Sheets("Zones").Range("E4:BB120").SpecialCells( _
xlCellTypeFormulas)
On Error GoTo haveError
If myRange Is Nothing Then Exit Sub
Application.Calculation = xlCalculationManual
For Each c In myRange.Cells
f = c.Formula
If f Like "=AVERAGE(*)" Then
c.Formula = "=IFERROR(" & Right(f, Len(f) - 1) & ",100%)"
i = i + 1
End If
Next c
MsgBox "Replaced " & i & " formulas"
haveError:
If Err.Number <> 0 Then MsgBox Err.Description
Application.Calculation = xlCalculationManual
End Sub