How would I write a VBA statement that basically says if "A1" says "Yes" ignore the rest of the my code and End otherwise go to the next line.
Thanks
I cant seem to get it to work, i cant get it to skip the rest of the code
Easy... ;-)
Sub YesICan()
Dim rng As Range
Set rng = Selection
Dim cl As Range
For Each cl In rng.Cells
If LCase(cl) = "yes" Then
cl.Offset(, 1) = "Hi There!"
Else
cl.Offset(, 1) = ""
'do other stuff
End If
Next cl
End Sub
Related
I'm trying to fill empty cells in a specified range. I have used code taken from other questions to write this:
Dim rCell As Range
For Each rCell In ws.Range("E36:G45")
If IsEmpty(rCell.Value) = True Or IsNull(rCell.Value) = True Or rCell.Value = "" Then
rCell.Value = -999
End If
Next rCell
This doesn't work, neither does the following (where the Boolean is removed):
For Each rCell In ws.Range("E36:G45")
If IsEmpty(rCell.Value) Or IsNull(rCell.Value) Or rCell.Value = "" Then
rCell.Value = -999
End If
Next rCell
The range E36:G45 contains a mix of empty and non-empty cells.
I have tried clearing the contents.
There are no sub procedures that could make the cells un-editable.
My guess is that the code is looking at a different worksheet - I suspect it's writing those -999s elsewhere.
If I were doing this, I'd use the following code:
Sub Fill_empty_cells()
On Error Resume Next
ws.Range("E36:G45").SpecialCells(xlCellTypeBlanks).Value = -999
On Error GoTo 0
End Sub
This definitely fills in cells that have been cleared using ClearContents.
That said, your original code does that also, hence my theory it's not looking at the same sheet you are.
To fully debug what's going on though, why not create some commentary so you read what's going on:
Sub test()
Dim rCell As Range
Set ws = ActiveSheet
For Each rCell In ws.Range("E36:G45")
If IsEmpty(rCell.Value) = True Or IsNull(rCell.Value) = True Or rCell.Value = "" Then
rCell.Value = -999
Else
Debug.Print "Not filling cell " & rCell.Address & " of sheet [" & rCell.Parent.Name & "] because it contains """ & rCell.Value & """"
End If
Next rCell
End Sub
Try simplifying your criteria; you can use len() combined with trim() to help with this, which will give your results as either 0 or >0:
dim cellRef as range
for each cellRef in ws.range("E36:G45")
Select case len(trim(cellRef.value))
Case 0
cellRef.value = -999
End select
Next cellRef
Edit1: Updated per Ben's comment;
I extracted the data according to ciriteria and marked them as blue. I'm looking for help with a Macro which would loop through all font colored cells (Blue) in a range.
I want to use only font colored cells in a range and mark in different color. And Msgbox show data that meet the criteria.
I had trouble finding information on looping through cells which contain only a specified colour. Anyone know how this could be done?
Dim i As Long
Dim LastRow As Integer
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Msg = "Data:"
For i = 1 To LastRow
If Cells(i + 1, 2).Value - Cells(i, 2).Value <> 0 Then
Cells(i, 2).Font.Color = vbBlue
Cells(i, 1).Font.Color = vbBlue
For Each Cell In Range("A:B")
If Cells(i, 1).Font.Color = vbBlue And Cells(i + 1, 1).Value - Cells(i, 1).Value > 4 Then
Cells(i, 2).Font.Color = vbGreen
Cells(i, 1).Font.Color = vbGreen
End If
Next
Msg = Msg & Chr(10) & i & " ) " & Cells(i, 2).Value & " : " & " --> " & Cells(i, 1).Value
End If
Next i
MsgBox Msg, vbInformation
There are multiple issues with your code:
Your loops are nested. You are searching through all the data every time you prepare one line. ==> Move the inner loop behind the loop you're coloring in.
The result message Msg = Msg & Chr(10) & i is constructed outside of the If Cells(i, 1).Font.Color = vbBlue And... condition, meaning that every line will be written into the result String. Move this part inside the 2nd loop, and the string should be contain only blue lines.
Also, please don't loop through For Each Cell In Range("A:B"). This will examine every cell in those columns, way beyond those who contain actual data. Use LastRow as in the first loop.
I believe you should be able to use the Find function to do this....
For example, select some cells on a sheet then execute:
Application.FindFormat.Interior.ColorIndex = 1
This will colour the cells black
Now execute something like:
Debug.Print ActiveCell.Parent.Cells.Find(What:="*", SearchFormat:=True).Address
This should find those cells. So you should be able to define your required Font with the FindFormat function.
BTW, make sure to test to see if the range returned is nothing for the case where it cant find any matches..
Hope that helps.
Edit:
The reason I would use the find method is because your code checks each cell in two columns. The Find method should be much quicker.
You will need to have a Do - While loop to find all cells in a range which is common with the Find function in VBA.
If you run this function, it should debug the address of any font matches that you are looking for - for a particular sheet. This should give you the idea...
Sub FindCells()
Dim rData As Range, rPtr As Range
Set rData = ActiveSheet.Range("A:B")
Application.FindFormat.Clear
Application.FindFormat.Font.Color = vbBlue
Set rPtr = rData.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
Debug.Print rPtr.Address
End If
Application.FindFormat.Clear
Application.FindFormat.Font.Color = vbGreen
Set rPtr = rData.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
Debug.Print rPtr.Address
End If
End Sub
Ok then - sorry keep getting distracted..
This code will search for cells with your fonts for a particular data range.
I believe you just need to implement your logic into the code...
Option Explicit
Public Sub Test()
Dim rData As Range
Set rData = Sheet1.Range("A:B")
Call EnumerateFontColours(rData, vbBlue)
Call EnumerateFontColours(rData, vbGreen)
End Sub
Public Sub EnumerateFontColours(ByVal DataRange As Range, ByVal FontColour As Long)
Dim rPtr As Range
Dim sStartAddress As String
Dim bCompleted As Boolean
Application.FindFormat.Clear
Application.FindFormat.Font.Color = FontColour
Set rPtr = DataRange.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
sStartAddress = rPtr.Address
Do
'**********************
Call ProcessData(rPtr)
'**********************
Set rPtr = DataRange.Find(What:="*", After:=rPtr, SearchFormat:=True)
If Not rPtr Is Nothing Then
If rPtr.Address = sStartAddress Then bCompleted = True
Else
bCompleted = True
End If
Loop While bCompleted = False
End If
End Sub
Public Sub ProcessData(ByVal r As Range)
Debug.Print r.Address
End Sub
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.
Good day,
I'm trying to end the loop I've done but not sure what should I enter. Once a value has been offset, that's it, I want to end the loop. Sometimes the value to find is more than one, and total of all data in the excel is until row 1500.
Please help me. Here's the code I've used below.
Sub third()
Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A1500").End(xlUp))
Do
Set c = SrchRng.Find("31184", LookIn:=xlValues)
If Not c Is Nothing Then c.Offset(0, 8).Value = "INPUT A NAME"
Loop
End Sub
How about:
Sub third()
Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A1500").End(xlUp))
Do
Set c = SrchRng.Find("31184", LookIn:=xlValues)
If Not c Is Nothing Then
c.Offset(0, 8).Value = "INPUT A NAME"
Exit Do
End If
Loop
End Sub
I have a Range("B6:T10000")
Data in the range are a mixture of blanks,#'s ,numbers (formatted as texts), texts and most importantly formulas.
Can someone please help with a VBA macro to:
Find anything that looks like number and convert it to number
Ignore the rest
Don't convert formulas to values
Thank you very much
You can do this without code, or with quicker code avoiding loops
Manual
Copy a blank cell
Select your range B6:T100001
Press F5. Then Goto ... Special
check Constants and then Text
Paste Special Multiply and check Add
This converts text only cells with numbers into numbers, and leaves actual text or formulae alone
Code
Sub Update()
Dim rng1 As Range
On Error Resume Next
Set rng1 = Range("B6:T10000").SpecialCells(xlCellTypeConstants, 2)
On Error Resume Next
If rng1 Is Nothing Then Exit Sub
'presumes last cell in sheet is blank
Cells(Rows.Count, Columns.Count).Copy
rng1.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
End Sub
here's my version:
Sub Test()
Dim rng as Range, cel as Range
Set rng = Thisworkbook.Sheets("Sheet1").Range("B6:T10000")
For Each cel In rng
If Not IsError(cel.Value) Then _
If Len(cel.Value) <> 0 And cel.HasFormula = False And _
IsNumeric(cel.Value) Then cel.Value = Val(cel.Value)
Next cel
End Sub
I've tested it, and works fine.
Hope this helps.
Give this a try:
Sub Converter()
Dim rBig As Range, r As Range, v As Variant
Set rBig = Range("B6:T10000")
For Each r In rBig
v = r.Value
If v <> "" And r.HasFormula = False Then
If IsNumeric(v) Then
r.Clear
r.Value = v
End If
End If
Next r
End Sub
EDIT#1:
This version ignores errors:
Sub Converter()
Dim rBig As Range, r As Range, v As Variant
Set rBig = Range("B6:T10000")
For Each r In rBig
v = r.Value
If Not IsError(v) Then
If v <> "" And r.HasFormula = False Then
If IsNumeric(v) Then
r.Clear
r.Value = v
End If
End If
End If
Next r
End Sub
ActiveSheet.Range("b5:b6004,h5:h6004").Select
For Each xCell In Selection
If IsNumeric(xCell) = False Then
xCell.Value = Val(xCell.Value)
Else
End If
Next xCell