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
Related
I am making a macro that Optimizes the sheet by deleting unused ranges that create very large file sizes. It does this by finding the last used row (column), selecting a range from that last used row (column) to the very bottom-right) of the sheet, and clearing formats and deleting those cells, to delete the unused range that is taking up space.
E.g. if last used row is 50, select range A50 to Bottom right of sheet (aka XFD104873, clear those formats and delete range
I have been able to do this with rows, but not with columns. In the below code, I get a syntax error (shown as 'SYNTAX ERROR' below) when case 2 runs, and I can't for the life of me figure out why.
I need to use R1C1 notation but for some reason the range(cells(#,#)) aren't picking it up properly.
I think it has to do with the second part in which I do range(cells(#,#)).End(xlDown).end(Toright)
Let me know if i can provide any additional information!
Nick
'Option Explicit
Sub Optimize()
'Call OptimizeSheet(1, "HR_Data")
Call OptimizeSheet(2, "DomesticAsset_Data")
'Call OptimizeSheet(3, "InternationalAsset_Data")
End Sub
Sub OptimizeSheet(ByVal choice As Long, ByVal sht As String)
' 1 = Rows
' 2 = Columns
' 3 = Both
If WorksheetExists(sht) = False Then
MsgBox "Worksheet doesn't exist, check macro code"
Exit Sub
End If
'Workbook
Dim wb As Workbook
'Last Row and Column Variables
Dim lr As Long
Dim lc As Long
'File Size variables
Dim aFileSize As Long
Dim bFileSize As Long
Dim chngFileSize As Long
Set wb = Application.ActiveWorkbook
On Error GoTo errHandler
'Get file size before optimizing
aFileSize = FileLen(Application.ActiveWorkbook.FullName)
Select Case choice
'Rows
Case 1:
lr = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
With Worksheets(sht).Range("A" & lr, Range("A" & lr).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
'Columns
Case 2:
lc = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
SYNTAX ERROR HERE
With Worksheets(sht).Range(Cells(1, lc), RangeCells(1, lc).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
'Both
Case 3:
lr = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
With Worksheets(sht).Range("A" & lr, Range("A" & lr).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
'chnge
lc = Worksheets(sht).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
With Worksheets(sht).Range(Cells(1, lc).Address(), Range(Cells(1, lc).Address()).End(xlDown).End(xlToRight))
.ClearFormats
.Delete
End With
Case Else:
MsgBox "Wrong Choice, check macro code"
End Select
Application.ThisWorkbook.Save
bFileSize = FileLen(Application.ActiveWorkbook.FullName)
If aFileSize + bFileSize = 0 Then
MsgBox "error in filesize"
End If
chngFileSize = bFileSize - aFileSize
If chngFileSize = 0 Then
MsgBox (sht & " already optimized")
Else
MsgBox ("Done. " & (chngFileSize / 1000) & "MB Saved")
End If
Exit Sub
errHandler:
MsgBox "error on line" & Erl
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As
Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
To delete columns:
With Worksheets(sht)
.Range(.Cells(1, lc + 1), _
.Cells(1, lc +1 ).End(xlToRight)).EntireColumn.Delete
End With
I need to remove some record from Excel spreadsheet. I want for macro to search for a certain name and upon finding a cell with that name, remove row containing it and next X rows.
So far I have a part that removes content of a cell upon certain words, but now I would need it to not clear but remove whole rows
Range("B2:H100").Replace What:="*Phone", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("B2:H100").Replace What:="*Queue", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("B2:H100").Replace What:="*2nd Line", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Try something like the code below:
Option Explicit
Sub RemoveRowsFindName()
Dim FindRng As Range
Dim xRows As Long
Dim FindWord As String
xRows = 7 ' number of extra rows to remove
FindWord = "Phone"
Set FindRng = Range("B2:H100").Find(What:=FindWord, LookAt:=xlPart, SearchOrder:=xlByRows)
If Not FindRng Is Nothing Then
Range("A" & FindRng.Row).Resize(1 + xRows, 1).EntireRow.Delete Shift:=xlShiftUp
Else ' word not found in range
MsgBox "Unable to find " & FindWord & " in range", vbCritical, "Find Error!"
End If
End Sub
#Shar Rado -
This would be a part of a bit larger script designed for clearing out excel spreadsheet to be more transparent for HR team, I've pasted your suggesion as:
Dim FindRng As Range
Dim xRows As Long
Dim FindWord As String
xRows = 7
FindWord = "Tony"
Set FindRng = Range("B2:H100").Find(What:=FindWord, LookAt:=xlPart, SearchOrder:=xlByRows)
If Not FindRng Is Nothing Then
Range("A" & FindRng.Row).Resize(1 + xRows, 1).EntireRow.Delete Shift:=xlShiftUp
End If
But the overall macro did the same it done previously - didn't return any errors nor did the needed removal.
I want to clear the contents if cell value is zero ((Either its in formula or value) The below code is working by selection of cells, but i want to do this for entire workbook please help me to change the code.
Sub DelZeros()
Dim c As Range
For Each c In Selection
If c.Value = 0 Then c.ClearContents
Next c
End Sub
Instead of Selection you could use ActiveSheet.UsedRange And if you need to do it for all sheets in a workbook you could do sth like that
Sub DelAllZeros()
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
Sub DelFormulaZeros()
Dim rg As Range, sngCell As Range
Dim sh As Worksheet
Dim result As Long
For Each sh In Worksheets
On Error Resume Next
Set rg = sh.Cells.SpecialCells(xlCellTypeFormulas, 1)
result = Err.Number
On Error GoTo 0
If result = 0 Then
For Each sngCell In rg
If sngCell.Value = 0 Then
sngCell.ClearContents
End If
Next
End If
Next
End Sub
Sub DelAllZeros()
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
ws.Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Set frange = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not frange Is Nothing Then
For Each c In frange
If c.Value = 0 Then
c.Formula = ClearContents
End If
Next c
End If
Set frange = Nothing
Next ws
Application.Calculation = xlCalculationAutomatic
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'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