From my GUI , I enter numbers like this: 9811,7841 which will be sent to my macro. My macro is:
sub highlight(fm as variant)
dim sh as worksheet
Dim i As Integer
dim j as integer
dim k As Long
Dim rn As Range
din number() as integer
If phm <> 0 Then
phm = Split(phm, ",")
ReDim number(LBound(phm) To UBound(phm)) As Integer
Set sh = w.Worksheets("Sheet1")
sh.Select
Cells.Find("Type").Select
ActiveCell.Offset(1, 0).Select
Set rn = sh.UsedRange
k = rn.Rows.Count + rn.Row - 1
For i = 1 To k
For j = LBound(number) To UBound(number)
number(j) = CInt(phm(j))
If ActiveCell.Value = number(j) Or IsEmpty(ActiveCell.Value) Then
Selection.Interior.ColorIndex = xlNone
Else
Selection.Interior.Color = vbGreen
Exit For
End If
Next j
ActiveCell.Offset(1, 0).Select 'moves activecell down one row.
Next i
End If
ActiveWorkbook.Save
End Sub
I would like to modify my code in such that alphabets are ignored if present in any cell.In the below case, cell3 and cell 5 should be highlighted as my "fm" contains 9811,7841 so cell 1,2,4 are valid.Alphabets should be ignored if any while checking the cells.
Sheet1
cell 1: 9811
cell 2: hello 9811
cell 3: 3428
cell 4: hello 7841
cell 5:hello 2545
The simplest way to do this is with a regular expression. Add a reference to Microsoft VBScript Regular Expressions, then just do a pattern replacement:
Private Function StripNonNumerics(inValue As String) As String
Dim regex As New RegExp
With regex
.Pattern = "\D"
.Global = True
StripNonNumerics = .Replace(inValue, vbNullString)
End With
End Function
Note that there'll be less overhead if you incorporate this into your sub or make the regex a global (that way you don't have to repeatedly create the RegExp object.
I think you are looking for the VBA function "Instr"
https://msdn.microsoft.com/en-us/en-en/library/8460tsh1%28v=vs.90%29.aspx
Assuming that phm is your array that contains one number of fm in every cell:
you need to change your line
If ActiveCell.Value = number(j) Or IsEmpty(ActiveCell.Value) Then
to
If Instr(ActiveCell.Value,number(j)) > 0 Or IsEmpty(ActiveCell.Value) Then
Related
I'm trying to create a VBA function that starts from the bottom of a range, and returns the first value that's different from the value at the bottom.
Example:
In the above table, I'd like to be able to grab the last value in the "Month" column (11), and iterate to the top until the value 10 is reached, and return that value.
I just started looking into VBA 3 days ago and am very unfamiliar with the language so I'm still trying to grok the syntax.
I have no doubt that my thinking is fuzzy with this, so I'd really appreciate feedback on my errors.
Here's what I have right now:
Code:
Function NextValue(num1 As Range)
For c = num1.End(xlDown) To num1.Item(1)
If Cells(c, 1) <> num1.End(xlDown) Then
NextValue = Cells(c, 1)
Exit For
End If
Next c
End Function
In case it's not clear, here's a description of what I'm trying to do, line-by-line.
1). Initiate a For-Loop that begins at the end of a range and decrements to the top
2). Check if that cell does not match the last value in that column
3). If it does not, then set the value of the function to that value
4). Terminate If statements, For loops, and end the function.
Your help is greatly appreciated.
Try this:
Function NextValue(num1 As Range) as Integer
Dim y As Integer
'get the last cell from num1
Set num1 = num1.End(xlDown)
y = -1
Do Until num1.Offset(y, 0).Value <> num1.Value
y = y - 1
Loop
'set function return to the different cell
NextValue = num1.Offset(y, 0).value
End Function
This will handle both compact ranges and disjoint ranges:
Option Explicit
Public Function SomethingElse(rng As Range) As Variant
Dim r As Range, values() As Variant
Dim i As Long, strvalue As Variant
ReDim values(1 To rng.Count)
i = 1
For Each r In rng
values(i) = r.Value
i = i + 1
Next r
strvalue = values(rng.Count)
For i = rng.Count To 1 Step -1
If values(i) <> strvalue Then
SomethingElse = values(i)
Exit Function
End If
Next i
SomethingElse = CVErr(xlErrNA)
End Function
Not clear to me if you want an UDF or a code to be used in a macro
in the first case you've already been given answers
in the latter case you may want to consider these two options:
Public Function FirstDifferent(rng As Range) As Variant
With rng.Parent.UsedRange
With Intersect(.Resize(, 1).Offset(, .Columns.Count), rng.EntireRow)
.Value = rng.Value
.RemoveDuplicates Array(1)
FirstDifferent = .Cells(.Rows.Count, 1).End(xlUp).Offset(-1).Value
If FirstDifferent = .Cells(.Rows.Count, 1) Then FirstDifferent = "#N/A"
.ClearContents
End With
End With
End Function
Public Function FirstDifferent(rng As Range) As Variant
With rng.Resize(, 1)
.AutoFilter Field:=1, Criteria1:=.Cells(.Rows.Count, 1)
FirstDifferent = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Cells(1, 1).Offset(-1).Value ' = 0 '<-- if any rows filtered other than headers one then change their column "B" value to zero
If FirstDifferent = .Cells(.Rows.Count, 1) Then FirstDifferent = "#N/A"
.Parent.AutoFilterMode = False
End With
End Function
I need help.
I have words and numbers in column A3:A500
and I need to change their names.
if a cell contains the word "previ" than put in a new column the letter "p" if the cells is a number. if its a word then dont put "p"
...like turning a flag on and off.
This is what i have:
Sub()
For i=3 to 500
x= range("a:"&i).value
If x contains "previ" Then
prevflag=1
ElseIf x is not integer Then
prevflag=0
End If
If prevflag=1 Then
range("H:"& i )= "p"
End If
Next i
End Sub
Can you guys help me make this work?
and thank you!!
this is what it needs to look like
https://postimg.org/image/e62z4xwlj/
Looking at your example, it looks like you want to put the "p" in rows in a section with a header that contains "previ" but not in a section with a header that doesn't. You also seem to want "p" in rows which have a blank in column A, not just integers. Does the below work for you?
Public Sub addPs()
Dim previFlag As Boolean
Dim c As Range: For Each c In Range("a1:a51")
If InStr(c.Value, "previ") > 0 Then
previFlag = True
ElseIf Not IsNumeric(c.Value) Then
previFlag = False
End If
If IsNumeric(c.Value) Then
If Int(c.Value) = c.Value And previFlag Then c.Offset(0, 3) = "p"
End If
Next c
End Sub
you may be after something like this
Option Explicit
Sub main()
Dim iRow As Long, lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).row
iRow = 3
Do
If InStr(Cells(iRow, 1).Value, "previ") > 0 Then '<--| if current cell contains "previ
iRow = iRow + 1 '<--| then then start scanning for numeric values
Do
If IsNumeric(Cells(iRow, 1).Value) Then Cells(iRow, 3).Value = "p" '<--| if current cell is numeric then write "p" two cells left of it
iRow = iRow + 1
Loop While InStr(Cells(iRow, 1).Value, "Type") = 0 And iRow <= lastRow
Else
iRow = iRow + 1 '<--| else skip to next row
End If
Loop While iRow <= lastRow
End Sub
just change the column offset to your needs (you wrote column "H" but your example has "p"s in column "C")
I did not understand the cases, but still, this is how you check for numeric values:
?isnumeric(6)
True
?isnumeric("test")
False
In your code:
else if not isnumeric(x) then
Does this need to be done with VBA? You could put this formula in H3 and paste it down to H500:
=IF(ISERROR(FIND("previ",A3)),"","p")
However, this doesnt deal with your number criteria, but I don't know what you mean by that. If a cell contains "previ", that cell is not numeric. It may have some numeric digits in it somewhere, but "previ04578" is not a number. Could you share some sample data? Failing that you can check for any numeric digit with stacked substitutions and a length comparison, for example:
=IF(ISERROR(FIND("previ",A3)),"",IF(LEN(A1)=LEN(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A3,"0",""),"9",""),"8",""),"7",""),"6",""),"5",""),"4",""),"3",""),"2",""),"1","")),"p",""))
Another alternative...
Sub FlagRows()
Dim i As Long, val As Variant, bFlag As Boolean: bFlag = False
With Sheets("Sheet1")
For i = 1 To 500
val = .Cells(i, 1).Value
bFlag = IIf(Not IsNumeric(val), IIf(InStr(CStr(val), "previ"), True, False), bFlag)
If IsNumeric(val) And bFlag = True Then .Cells(i, 4).Value = "p"
Next i
End With
End Sub
My goal is to hide the column if all value from row 3 to 10 are zero in that column, so I create formula in the row 11 which is sum of the value from row 3 to 10
Basicly I can create code like this
If Range("B11").Value = 0 Then
Columns("B:B").EntireColumn.Hidden = True
Else
Columns("B:B").EntireColumn.Hidden = False
End If
If Range("C11").Value = 0 Then
Columns("C:C").EntireColumn.Hidden = True
Else
Columns("C:C").EntireColumn.Hidden = False
End If
but how to simply this, because I want to this macro run from Column B to FV,
or maybe any other solution to achieve my goal?
A well placed loop would help and the join function:
Dim X as Long
Columns("B:FV").EntireColumn.Hidden = False
For X = 2 To 178
If Join(Application.Transpose(Range(Range(Cells(3, X).Address & ":" & Cells(10, X).Address).Address).Value), "") = "00000000" Then Columns(X).Hidden = True
Next
Unhide ALL the columns first then you have removed the need for your else statement
Edit: With this solution, you also don't need your formula in row 11.
I have surprised no one write the easiest answer.
for i = 2 to 178
if cells(11, i).value = 0 then
Columns(i).EntireColumn.Hidden = True
end if
next
Heres one way.
Sub test()
Dim iStart As Long: iStart = Range("B1").Column
Dim iFin As Long: iFin = (Range("FV1").Column) - 1
Dim iCntCol As Long: iCntCol = iStart 'Col B is #2
For iCntCol = iStart To iFin 'FV is Col # 178
If Cells(11, iCntCol).Value = 0 Then
Columns(iCntCol).EntireColumn.Hidden = True
Else
Columns(iCntCol).EntireColumn.Hidden = False
End If
Next iCntCol
End Sub
HTH
should performance be an issue, consider what follows
Option Explicit
Sub hide()
Dim found As Range
With Intersect(ActiveSheet.Range("B11:FV11"), ActiveSheet.UsedRange.EntireColumn)
.EntireColumn.Hidden = False
.FormulaR1C1 = "=sum(R3C:R10C)"
Set found = GetZeroColumns(.Cells, 0)
End With
If Not found Is Nothing Then found.EntireColumn.Hidden = True
End Sub
Function GetZeroColumns(rng As Range, value As Variant) As Range
Dim firstAddress As String
Dim found As Range
With rng
Set found = .Find(What:=value, LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
firstAddress = found.Address
Set GetZeroColumns = found
Do
Set GetZeroColumns = Union(GetZeroColumns, found)
Set found = .FindNext(found)
Loop While Not found Is Nothing And found.Address <> firstAddress
End If
End With
End Function
We could use a more versatile code to do this, by not hard coding the range of consideration, so that it can be reused in many places. Consider below, the For...Next loop will test each cell in Selection. Selection is the current selected cells. So just select the cells you want the code to run on. If a cell's value equals 0, then the column will be marked for hiding. I'd also not recommend hiding the column one-by-one, it makes the code unnecessarily slow, especially when there are a lot of formulas in the sheet or there are many columns to hide. So what i did is just mark the columns for hiding using the Union function. Then hide them at one go which you can see at the last line of the code.
Sub HideZerosByColumn()
Dim iRng As Range
Dim uRng As Range
Set uRng = Nothing
For Each iRng In Selection
If iRng = 0 And Not IsEmpty(iRng) Then
If uRng Is Nothing Then Set uRng = iRng Else Set uRng = Union(uRng, iRng)
End If
Next iRng
If Not uRng Is Nothing Then uRng.EntireColumn.Hidden = True
End Sub
Before running the code, select the range for consideration.
After running the code
I am trying to clear all the number constants in a range of cells without clearing any formulas or cell references. Clearing the constants from cells without any formulas or cell references is simple but I am having trouble doing it when those are present. Below is the code I have so far.
Range("B2:B11").Select
Selection.SpecialCells(xlCellTypeConstants, 1).Select
Selection.ClearContents
In this range cells B5 and B7 have formulas with cell references as follows:
B5: =(G83*H1)+1181.05
B7: =E33+1292.76
The cell references will also at times reference cells on other sheets in the same workbook. I need to clear the constants from these formulas while leaving the references intact.
This will remove constants from all formulas in current workbook based on 2 patterns:
"=Formula-[Space]-PlusSign-[Space]-Constant" (space optional)
=(G83*H1)+1181.05 or =(G83*H1) +1181.05 or =(G83*H1)+ 1181.05 becomes =(G83*H1)
=E33+1292.76 or =E33 +1292.76 or =E33+ 1292.76 or =E33 + 1292.76 becomes =E33
"=Formula-[Space]-MinusSign-[Space]-Constant" (space optional)
Public Sub clearConstantsFromWorkBookFormulas()
Const PATTERNS As String = "~+*|~+ *|~ +*| ~+ *|~-*|~- *|~ -*|~ - *"
Dim pat As Variant
For Each pat In Split(PATTERNS, "|")
Cells.Replace What:=pat, _
Replacement:=vbNullString, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False
Next
End Sub
.
This is a more generic option using regEx pattern matching and arrays:
Public Sub testClear()
Dim ws As Worksheet
For Each ws In Application.ActiveWorkbook.Worksheets
removeConstantsFromFormulas ws.Range("B2:B11"), getRegEx
Next
End Sub
Public Sub removeConstantsFromFormulas(ByRef rng As Range, ByRef regEx As Object)
Dim v As Variant, r As Long, c As Long, lr As Long, lc As Long
lr = rng.Rows.Count
lc = rng.Columns.Count
If lr > 0 And lc > 0 Then
v = rng.Formula
For r = 1 To lr
For c = 1 To lc
If Left(v(r, c), 1) = "=" Then
If regEx.Test(v(r, c)) Then v(r, c) = regEx.Replace(v(r, c), vbNullString)
End If
Next
Next
rng.Formula = v
End If
End Sub
Private Function getRegEx() As Object
Set getRegEx = CreateObject("VBScript.RegExp")
getRegEx.Pattern = "[^a-zA-Z][0-9]+(\.?[0-9]+)"
getRegEx.Global = True
getRegEx.IgnoreCase = True
End Function
RegEx pattern: one or more digits, digit group not preceded by a letter, with or without a fraction part
This attempt should handle most examples using a Regexp.
There may be some edge cases as the discussion above points out. For the code below
=(G83*H1)+1181.05
=10+A1
=A1+10
=A1+(10)
=A1+10.0
becomes
=(G83*H1)
=+A1
=A1
=A1
=A1
I note it would also take out the ^2 in =A1^2
It clearly also won't cater for named formulae (named ranges).
Updated: Now handles cascading parentheses, ie
=A1+(27+(11-2))
becomes
=A1
Sub Format()
Dim objRegexB As Object
Dim lngCnt As Long
Dim X
X = [b2:b11].Formula
Set RegExB = CreateObject("vbscript.regexp")
With RegExB
.Pattern = "[=\+\/\*^\-](\([0-9]\d*(\.\d+)?\)|[0-9]\d*(\.\d+)?|\.\d+)"
.Global = True
For lngCnt = 1 To UBound(X)
Do While .Test(X(lngCnt, 1))
X(lngCnt, 1) = .Replace(X(lngCnt, 1), vbNullString)
Loop
Next
End With
[b2:b11].Formula = X
End Sub
First and foremost, the below works as expected. I'm trying to make the macro mimic one we have in word. Our word macro will select the entire column simply to display which column is currently being processed (the selection object is not used for any actual processing).
In excel, when I attempt to select the column (activecell.entirecolumn.select) if there is a merged cell it will show multiple columns. I need it only to select the letter column (pretty much the same as clicking the letter at the top) of the active cell. I'm hoping for a method that wont require me to parse the address of the cell if possible (I feel like string parsing is sloppy).
Sub setwidths()
Dim rangeName As String
Dim selectedRange As range
Dim tempRange As range
Dim x As Integer
'If only 1 cell is selected, attempt to find the correct named range
If Selection.Cells.Count = 1 Then
rangeName = Lib.getNamedRange(Selection) 'Built in function from my lib (works I promise)
If rangeName <> "" Then
Application.Goto reference:=rangeName
End If
End If
Set selectedRange = Selection
'Go column by column asking for the width
'Made to mimic a word MACRO's behavior and moving backwards served a point in word
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x)
tempRange.Cells(tempRange.Cells.Count, 1).Select
'This is where the code should go to select the column
tempRange.ColumnWidth = InputBox("This columns?")
Next
End Sub
Is there anyway to select a column by letter (range("A:A").select for instance) from within an active cell?
Edit:
Record MACRO shows that columns("A:A").select is used when clicking the letter at the top; however, entering that same line into the immediate window will select all columns that merged cells are merged across same as with range("A:A").select and activecell.selectcolumn
Sub NSTableAdjust()
Dim rangeName As String
Dim selectedRange As range
Dim tempRange As range
Dim cellsColor() As Long
Dim cellsPattern() As XlPattern
Dim cellsTaS() As Long
Dim cellsPTaS() As Long
Dim result As String
Dim abort As Boolean
Dim x As Integer
Dim y As Integer
'Delete the block between these comments and run macro on 10x10 grid in excel to test
If Selection.Cells.Count = 1 Then
rangeName = Lib.getNamedRange(Selection)
If rangeName <> "" Then
Application.Goto reference:=rangeName
End If
End If
'Delete the block between these comments and run macro on 10x10 grid in excel to test
Set selectedRange = Selection
ReDim cellsArr(1 To selectedRange.Rows.Count)
ReDim cellsColor(1 To UBound(cellsArr))
ReDim cellsPattern(1 To UBound(cellsArr))
ReDim cellsTaS(1 To UBound(cellsArr))
ReDim cellsPTaS(1 To UBound(cellsArr))
abort = False
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x)
tempRange.Cells(tempRange.Cells.Count, 1).Select
For y = 1 To UBound(cellsColor)
With tempRange.Cells(y, 1).Interior
cellsColor(y) = .Color
cellsPattern(y) = .Pattern
cellsTaS(y) = .TintAndShade
cellsPTaS(y) = .PatternTintAndShade
.Color = 14136213
End With
Next
result = InputBox("This Column?")
If IsNumeric(result) Then
tempRange.ColumnWidth = result
Else
abort = True
End If
For y = 1 To UBound(cellsColor)
With tempRange.Cells(y, 1).Interior
.Color = cellsColor(y)
.Pattern = cellsPattern(y)
.TintAndShade = cellsTaS(y)
.PatternTintAndShade = cellsPTaS(y)
End With
Next
If abort Then
Exit Sub
End If
Next
End Sub
My current solution to simply shade the cells and then restore their original shading after processing the column.
After an obviously lengthy discussion in the comments on the post. It appears the answer to my question is simply "Not Possible."
The solution I settled on in an attempt to get as close to the "Look" I was searching for is below:
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x) 'Range of the column
'Our standards dictate the last cell in the range will not be merged
With tempRange.Cells(tempRange.Cells.Count, 1)
.Select 'Selecting here will for excel to make sure the range is in view
'Very simple/basic conditional formatting rule
Set fCondition = .EntireColumn.FormatConditions. _
Add(Type:=xlExpression, Formula1:="=True")
fCondition.Interior.Color = 15123099
'Make sure it is the highest priority rule
fCondition.Priority = 1
End With
'Get user input
result = InputBox("This Column?")
'Delete rule
fCondition.Delete
'Validate user input
If IsNumeric(result) Then
tempRange.ColumnWidth = result
Else
abort = True
End If
If abort Then
Exit Sub
End If
Next