Replace empty by 0 - excel

I want to check all cells in columns D to O. If the cell is empty, replace it by a hard zero.
I have this code:
Sub replace()
Dim rng As Range, cell As Range
Dim aantalrijen As Long
With Worksheets("Schaduwblad")
aantalrijen = .Range("A1", .Range("A1").End(xlDown)).Cells.Count - 1
Set rng = .Range(.Cells(2, "D"), .Cells(aantalrijen, "O"))
For Each cell In rng
cell = WorksheetFunction.Substitute(cell, "", "0")
Next
End With
End Sub
This code hangs during processing. Only option is to end the routine by pressing Escape.

You don't need to loop through all the cells. Let Excel find the empties with .SpecialCells:
On Error Resume Next
rng.SpecialCells(xlCellTypeBlanks, xlCellTypeConstants).Value = 0
On Error GoTo 0
The error trap is required in case no empty cells are found.
So your whole routine could be replaced with:
Sub replace()
On Error Resume Next
With Worksheets("Schaduwblad")
.Range(.Cells(2, "D"), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, "O")) _
.SpecialCells(xlCellTypeBlanks, xlCellTypeConstants).Value = 0
End With
On Error GoTo 0
End Sub
Further to your comment below, here is a version of the same code, but working on a row-by-row basis. To test this, I built a 227,000 x 15 block of data and then using a random number generator punched 100,000 holes into it, emptying those cells. I then ran the following code, which took 33 seconds to fill those 100,000 holes back in.
Sub replace()
Dim rangesection As Range
On Error Resume Next
With Worksheets("Schaduwblad")
For Each rangesection In .Range(.Cells(2, "D"), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, "O")).Rows
rangesection.SpecialCells(xlCellTypeBlanks, xlCellTypeConstants).Value = 0
Next
End With
On Error GoTo 0
End Sub

I've never used the substitute methode.. I would do this by checking if cell is empty with the IsEmpty() function.
So yo can swap
cell = WorksheetFunction.Substitute(cell, "", "0")
with
If IsEmpty(cell) Then cell.value = 0
Full code:
Sub replace()
Dim rng As Range, cell As Range
Dim aantalrijen As Long
With Application.ThisWorkbook.Worksheets("Schaduwblad")
aantalrijen = .Range("A1", .Range("A1").End(xlDown)).Cells.Count - 1
Set rng = .Range(.Cells(2, "D"), .Cells(aantalrijen, "O"))
For Each cell In rng
If IsEmpty(cell) Then cell.value = 0
Next
End With
End Sub

Related

How to work with data on multiple selection within a filter being applied?

I had to rework the code a bit as I got the Error1004: pastespecial method of worksheet class failed I just specified the range for PasteSpecial xlPasteValues see the code:
Sub AvoidingSelect()
Dim rng As Range, cll As Range Set rng = Range("G2:G12854")
Sheets("Data").Range("G2:G12854").SpecialCells(xlCellTypeVisible).Copy Sheets("Data").Range("G2:G12854").PasteSpecial xlPasteValues
Application.CutCopyMode = False
For Each cll In rng
If IsNumeric(cll.Value) Then Range("G2:G12854") = Application.WorksheetFunction.RoundDown(cll.Value, 8) End If
Next End Sub
However, the last part is not working. It picks the first cell.value in the row and copy it into each cell all the way down so the value of cell H1084 is in every cell now.
Reminder, What is Rounddown's syntax? From the Microsoft Excel documentation:
ROUNDDOWN(number, num_digits)
Number – Required. Any real number that you want rounded down.
Num_digits – Required. The number of digits to which you want to round number.
So in your code the first mistake I saw is here :
Selection.WorksheetFunction.RoundDown (Activecell.Value)
This line must be like below :
Application.WorksheetFunction.RoundDown (Activecell.Value , 0)
So your code would be like that :
Sub Macro1()
Dim Activecell As Range
Dim rounddownvar As Double
Selection.SpecialCells(xlCellTypeVisible).Select
For Each Activecell In Selection
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
rounddownvar = Application.WorksheetFunction.rounddown(Activecell.Value, 1)
Debug.Print rounddownvar
Next Activecell
End Sub
I added Application.WorksheetFunction.rounddown(Activecell.Value, 1) into a var because this line returns a number ...
Without select to be more efficient :
Sub AvoidingSelect()
Dim rng As Range, cll As Range
Set rng = Range(Range("A2:B2"), Range("A2:B2").End(xlDown)).SpecialCells(xlCellTypeVisible)
Sheets("Sheet1").Range("A1:AA100000").SpecialCells(xlCellTypeVisible).Copy
Sheets("Sheet1").PasteSpecial xlPasteValues
For Each cll In rng
If IsNumeric(cll.Value) Then
Debug.Print Application.WorksheetFunction.RoundDown(cll.Value, 0)
End If
Next
End Sub
CAUTION:
Please respect RoundDown syntax :
RoundDown(cll.Value, 0) here 0 is the number of digit you want to delete after the , .
For Example :
RoundDown(cll.Value, 0) give : 0.000
RoundDown(cll.Value, 3) give : 0
Working :
Sub AvoidingSelect()
Dim rng As Range, cll As Range
Set rng = Range(Range("G2:G12854"), Range("G2:G12854").End(xlDown)).SpecialCells(xlCellTypeVisible)
Sheets("Sheet1").Range("G2:G12854").SpecialCells(xlCellTypeVisible).Copy
Sheets("Sheet1").Range("G2:G12854").PasteSpecial xlPasteValues
For Each cll In rng
If IsNumeric(cll.Value) Then
Debug.Print cll.Value
cll = Application.WorksheetFunction.RoundDown(cll.Value, 8)
End If
Next
End Sub

how to set a cell to 0 if its blank and another cell has data

so i have this code and what i want to do is the following:
if Range("aj61:aj432") is blank and Range("F61:F432") has text, then set the blank cells to 0
Here is what I tried but got a type mismatch
Sub Insert_0()
Dim rng As Range
Set rng = Range("AJ61:AJ432")
If IsEmpty(rng) And rng.Offset(-30, 0) <> "" Then rng.Value = 0
End Sub
Use SpecialCells to capture the rows from text values in column F intersecting with the blank values in column AJ.
Option Explicit
Sub Insert_0()
Dim rng As Range
On Error Resume Next
Set rng = Intersect(Range("F61:F432").SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow, _
Range("AJ61:AJ432").SpecialCells(xlCellTypeBlanks))
On Error GoTo 0
If Not rng Is Nothing Then
rng = 0
Else
Debug.Print Err.Number & ": " & Err.Description
On Error GoTo -1
End If
End Sub
You need to loop through range:
For i = 61 To 432
If Cells("AJ" & i).Value = "" And Cells("F" & i).Value <> "" Then Cells("AJ" & i).Value = 0
Next
no loops
Sub Insert_0()
Intersect(Range("F61:F432").SpecialCells(xlCellTypeConstants).EntireRow, Range("AJ:AJ")).SpecialCells(xlCellTypeBlanks).Value = 0
End Sub
If you want to check if a range of multiple cells is blank, you need to use something like:
If WorksheetFunction.CountA(rng) = 0 Then
You would have to loop through the cells in the range. Something like:
dim cel as range
for each cel in rng.cells
If IsEmpty(cel) And cel.Offset(-30, 0) <> "" Then cel.Value = 0
next
to make it faster you could fill an array with the values of the range

Code seems to run forever and Error: block variable not set (VBA)

I am completely new to VBA so please bear with me.
I am trying to write a sub-procedure that will loop through each row in a certain column and compare to another sheet's criteria. if it contains "x", for example, then the value will be returned. However, when I try running the code, the codes run forever and causes the computer to hang.
Here's the code that I have written so far. It keeps prompting an error: Object variable and with block variable not set. PS: I have obtained errors when using 'Application.WorksheetFunction.Index' and when reading other threads, it was suggested to delete 'WorksheetFunction'. I'm not sure if that causes the problem and I would also like to clarify the rationale behind removing the words 'WorksheetFunction'
Thank you so much in advance!
Sub sub_inputData()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastrow as range
lastrow = ws.Cells (ws.Rows.Count, 17).End (xlUp).row
Dim rng As Range
Set rng = ws.Range("Q4:Q" & lastrow)
Dim rngCell As Range
On Error Resume Next
For Each rngCell In rng
If rngCell.Offset(0, -13) = "x" Then
rngCell = Application.Index(Sheets("Data").Range _
("D805:D813"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
("D805:D813"), 1))
ElseIf rngCell.Offset(0, -13) = "y" Then
rngCell = Application.Index(Sheets("Data").Range _
("D27:D34"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
("D27:D34"), 1))
ElseIf rngCell.Offset(0, -13) = "z" Then
rngCell = Application.Index(Sheets("Data").Range _
("D718:D726"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
("D718:D726"), 1))
Else: rngCell = vbNullString
End If
Next rngCell
Call sub_code2
Call sub_code3
Set rngCell = Nothing
Set rng = Nothing
End Sub
Couple issue with your code that has been modified here.
1) Dim lastrow As Long, not Range
2) Else: is not necessary, just use Else
3) Set rngCell = Nothing & Set rng = Nothing is not necessary. See this link for explanation
4) Since you are only checking the value of 1 cell, you can use Select Case for a moderately cleaner code.
5) On Error Resume Next is no good for de-bugging code. You want to see the errors so you can handle them. I recommend looking up the do's and dont's of that bit of code.
Sub sub_inputData()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastrow As Long: lastrow = ws.Range("Q" & ws.Rows.Count).End(xlUp).Row
Dim rng As Range: Set rng = ws.Range("Q4:Q" & lastrow)
Dim rngCell As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each rngCell In rng
Select Case rngCell.Offset(0, -13)
Case "x"
rngCell = Application.Index(Sheets("Data").Range _
("D805:D813"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
("D805:D813"), 1))
Case "y"
rngCell = Application.Index(Sheets("Data").Range _
("D27:D34"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
("D27:D34"), 1))
Case "z"
rngCell = Application.Index(Sheets("Data").Range _
("D718:D726"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
("D718:D726"), 1))
Case Else
rngCell = ""
End Select
Next rngCell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call sub_code2
Call sub_code3
End Sub
another possibility is using Switch() function:
Sub sub_inputData()
Dim rngCell As Range, rangeToSearch As Range
Dim val As Variant
With ActiveSheet ' reference data sheet (better: With Worksheets("MyDataSheetName"))
For Each rngCell In .Range("Q4", .Cells(.Rows.Count, "Q").End(xlUp)) ' loop throughreferenced sheet column Q cells from row 4 down to last not empty one
val = rngCell.Offset(, -13).Value2 ' store column D current cell row value
Set rangeToSearch = Sheets("Data").Range(Switch(val = "x", "D805:D813", val = "y", "D27:D34", val = "z", "D718:D726", True, "A1")) ' set range to search into with respect to stored value. set it to "A1" to signal no search is needed
If rangeToSearch.Address <> "$A$1" Then ' if search is needed
rngCell.Value = Application.Index(rangeToSearch, Application.Match(rngCell.Offset(, -15).Value2, rangeToSearch, 1)) 'do the lookup
Else
rngCell.ClearContents ' clear current cell
End If
Next
End With
sub_code2 ' no need for 'Call' keyword
sub_code3 ' no need for 'Call' keyword
End Sub
It looks like you are effectively picking a lookup range based on the value in column D, and then doing a lookup against that range based on the value in column B.
If so, you can do this entirely with formulas, which will be more efficient because it will only run on particular cells when needed (i.e. only when their inputs change).
Here's an example, using Tables and Table Notation. Tables are perfect for this, as you never have to amend your formulas to handle new data.
The formula in C2 is =VLOOKUP([#ID],CHOOSE(VLOOKUP([#Condition],Conditions,2,FALSE),X,Y,Z),2,FALSE)
That formula uses the 'Conditions' Table in E1:F3 to work out which of the other tables to do the lookup on. I've named those other tables X, Y, and Z.

Remove object required message in cancel option of inputbox

Is there any way to remove error message(object required message) that pops out from the input box whenever the user presses the cancel button?
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
Set rng = Application.InputBox("Copy to", Type:=8)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
End Sub
Not quite sure why you are using the inputbox, you don't even use it in the code.
This should take care of the errors.
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set rng = Nothing
Set inp = Selection
inp.Interior.ColorIndex = 37
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled...", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
End If
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
Application.CutCopyMode = 0
End Sub
That is not a InputBox error. That is your wrong usage. In your code, you immediately set value from InputBox return. That may cause error because of setting empty value("") to an Range object.
So, you need to modify as follow:
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
Dim inputRange As String
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
inputRange = Application.InputBox("Copy to")
If Not IsEmpty(inputRange) Then
Set rng = Range(inputRange)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then
cell.Clear
End If
Next
End If
End Sub
Not tested. Suggestion for you. If it is not work, let me know.

runtime error 91 object variable or with block variable not set database

I have a database where all the data are in majuscule and I'm trying to keep only the first letter like that, my code is
Sub nompropio()
Dim rng As Range
Dim cell As Range
Set rng = Range("A1:T17058")
For Each cell In rng
Next cell
If Not cell.HasFormula Then >>>here is the eror
End If
cell.Value = WorksheetFunction.Proper(cell.Value)
End Sub
I don't know if having blank cells is a problem or if some columns are only numbers but none of those cells have formula i just put it because the example was like that and I tried to work it without that part but neither it worked.
It should work with this syntax:
Sub nompropio()
Dim rng As Range
Dim cell As Range
Set rng = Range("A1:T17058")
For Each cell In rng
If Not cell.HasFormula Then cell.Value = WorksheetFunction.Proper(cell.Value)
Next
End Sub
updated post
The version below uses variant arrays and SpecialCells to run the same process much faster than the range loop version above.
Sub Recut()
Dim X
Dim rng1 As Range
Dim rng2 As Range
Dim lngRow As Long
Dim lngCol As Long
On Error Resume Next
Set rng1 = Range("A1:T17058").SpecialCells(xlConstants)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
For Each rng2 In rng1.Areas
If rng2.Cells.Count > 1 Then
X = rng2.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
X(lngRow, lngCol) = WorksheetFunction.Proper(X(lngRow, lngCol))
Next
Next
rng2.Value2 = X
Else
rng2.Value = WorksheetFunction.Proper(rng2.Value)
End If
Next
End Sub
The error you're indicating comes because the variable is out of scope. In fact,
In your loop, you define the variable implicitly:
For Each cell In rng
Next cell
Out of the Each loop, you try to call the variable:
If Not cell.HasFormula Then '>>>here is the error, because "cell" it's something within the previous loop, but it's nothing here so the compiler tells you "hey, I'm sorry, but I didn't set your variable".
End If
Clearly, the variable is out-of-scope because it is defined in the For Each loop so it exists only within the scope of the loop. If you want to perform something on each cell without formulas, then this is the right way to go:
For Each cell In rng '<-- for each cell...
If Not cell.HasFormula Then '<-- perform if the cell has no formula
cell.Value = WorksheetFunction.Proper(cell.Value) '<--action to perform
End If '<-- end the if-then statement
Next cell '<-- go to the next cell of the range

Resources