Iterating through a range until you find different value in VBA - vba

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

Related

VBA not able to discern between empty cells, numeric cells, and text?

I am trying to read cells in VBA and do certain things based on the contents of them. However, VBA is unable to accurately determine if the contents of a cell are blank, numeric, or text. It will think that cells with only a '1' in them are blank, and cells with text are blank. If it makes a difference, I turn off all screen updating and the like when this runs.
Please see code below:
Function IsNumber(ByRef expression As Variant) As Boolean
IsNumber = Not IsEmpty(expression) And IsNumeric(expression)
End Function
Function IsText(ByRef expression As Variant) As Boolean
IsText = Not IsEmpty(expression) And Not IsNumeric(expression)
End Function
Sub RA()
Dim cell As Range
With ActiveWorkbook.Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set r = Worksheets("Sheet1").Range(Cells(3, 3), Cells(lastrow, lastCol - 1))
End With
For i = 3 To lastrow
Set c = Cells(i, 3)
Select Case True
Case S1_Func(c)
End Select
Next i
End Sub
Function S1_Func(c As Variant)
Dim SR As Worksheet
Set SR = Worksheets("Financials")
Dim c2 As Range
Set c2 = c.Offset(0, 1)
If IsNumber(c2.Value2) Then
Select Case True
Case SR.Cells(i, 5).Value2 = "LY"
End Select
ElseIf IsText(c2.Value2) Then
Cells(i, 72).Value2 = "Incorrect"
End If
End sub
Updated after discussion below.
Function IsNumber(ByRef expression As Variant) As Boolean
IsNumber = expression <> "" And IsNumeric(expression)
End Function
Function IsText(ByRef expression As Variant) As Boolean
IsText = expression <> "" And Not IsNumeric(expression)
End Function
Original post:
There are some mixed problem in your code. The Select statement have several issues and is very misleading. In this case you can't use Select. If is your best option. Try something like this:
Sub Example()
If Len(Value) = 0 Then
'Empty
ElseIf IsNumeric(Value) Then
'Numeric
Else
'Alphanumeric
End If
End Sub

Excel / VBA - get first normal form (1NF) [duplicate]

I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.
I have a variable number of rows.
I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.
Example:
ColA ColB ColC ColD
Monday A,B,C Red Email
Output:
ColA ColB ColC ColD
Monday A Red Email
Monday B Red Email
Monday C Red Email
Have tried something like:
colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
Rows.Insert(i)
Next i
Try this, you can easily adjust it to your actual sheet name and column to split.
Sub splitByColB()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
Do While r.row > 1
ar = Split(r.value, ",")
If UBound(ar) >= 0 Then r.value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
You can also just do it in place by using a Do loop instead of a For loop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:
Dim workingRow As Long
workingRow = 2
With ActiveSheet
Do While Not IsEmpty(.Cells(workingRow, 2).Value)
Dim values() As String
values = Split(.Cells(workingRow, 2).Value, ",")
If UBound(values) > 0 Then
Dim colA As Variant, colC As Variant, colD As Variant
colA = .Cells(workingRow, 1).Value
colC = .Cells(workingRow, 3).Value
colD = .Cells(workingRow, 4).Value
For i = LBound(values) To UBound(values)
If i > 0 Then
.Rows(workingRow).Insert xlDown
End If
.Cells(workingRow, 1).Value = colA
.Cells(workingRow, 2).Value = values(i)
.Cells(workingRow, 3).Value = colC
.Cells(workingRow, 4).Value = colD
workingRow = workingRow + 1
Next
Else
workingRow = workingRow + 1
End If
Loop
End With
This will do what you want.
Option Explicit
Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim lastrow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet4").Copy After:=.Worksheets("Sheet4")
Set ws = ActiveSheet
End With
With ws
lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = lastrow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub
A formula solution is close to your requirement.
Cell G1 is the delimiter. In this case a comma.
Helper E1:=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H$1,"")))+1
You must fill the above formula one row more.
A8:=a1
Fill this formula to the right.
A9:=LOOKUP(ROW(1:1),$E:$E,A:A)&""
Fill this formula to the right and then down.
B9:=MID($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))+1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)+1))-FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))-1)&""
Fill down.
Bug:
Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.
Given #A.S.H.'s excellent and brief answer, the VBA function below might be a bit of an overkill, but it will hopefully be of some help to someone looking for a more "generic" solution. This method makes sure not to modify the cells to the left, to the right, or above the table of data, in case the table does not start in A1 or in case there is other data on the sheet besides the table. It also avoids copying and inserting entire rows, and it allows you to specify a separator other than a comma.
This function happens to have similarities to #ryguy72's procedure, but it does not rely on the clipboard.
Function SplitRows(ByRef dataRng As Range, ByVal splitCol As Long, ByVal splitSep As String, _
Optional ByVal idCol As Long = 0) As Boolean
SplitRows = True
Dim oldUpd As Variant: oldUpd = Application.ScreenUpdating
Dim oldCal As Variant: oldCal = Application.Calculation
On Error GoTo err_sub
'Modify application settings for the sake of speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Get the current number of data rows
Dim rowCount As Long: rowCount = dataRng.Rows.Count
'If an ID column is specified, use it to determine where the table ends by finding the first row
' with no data in that column
If idCol > 0 Then
With dataRng
rowCount = .Offset(, idCol - 1).Resize(, 1).End(xlDown).Row - .Row + 1
End With
End If
Dim splitArr() As String
Dim splitLb As Long, splitUb As Long, splitI As Long
Dim editedRowRng As Range
'Loop through the data rows to split them as needed
Dim r As Long: r = 0
Do While r < rowCount
r = r + 1
'Split the string in the specified column
splitArr = Split(dataRng.Cells(r, splitCol).Value & "", splitSep)
splitLb = LBound(splitArr)
splitUb = UBound(splitArr)
'If the string was not split into more than 1 item, skip this row
If splitUb <= splitLb Then GoTo splitRows_Continue
'Replace the unsplit string with the first item from the split
Set editedRowRng = dataRng.Resize(1).Offset(r - 1)
editedRowRng.Cells(1, splitCol).Value = splitArr(splitLb)
'Create the new rows
For splitI = splitLb + 1 To splitUb
editedRowRng.Offset(1).Insert 'Add a new blank row
Set editedRowRng = editedRowRng.Offset(1) 'Move down to the next row
editedRowRng.Offset(-1).Copy Destination:=editedRowRng 'Copy the preceding row to the new row
editedRowRng.Cells(1, splitCol).Value = splitArr(splitI) 'Place the next item from the split string
'Account for the new row in the counters
r = r + 1
rowCount = rowCount + 1
Next
splitRows_Continue:
Loop
exit_sub:
On Error Resume Next
'Resize the original data range to reflect the new, full data range
If rowCount <> dataRng.Rows.Count Then Set dataRng = dataRng.Resize(rowCount)
'Restore the application settings
If Application.ScreenUpdating <> oldUpd Then Application.ScreenUpdating = oldUpd
If Application.Calculation <> oldCal Then Application.Calculation = oldCal
Exit Function
err_sub:
SplitRows = False
Resume exit_sub
End Function
Function input and output
To use the above function, you would specify
the range containing the rows of data (excluding the header)
the (relative) number of the column within the range with the string to split
the separator in the string to split
the optional (relative) number of the "ID" column within the range (if a number >=1 is provided, the first row with no data in this column will be taken as the last row of data)
The range object passed in the first argument will be modified by the function to reflect the range of all the new data rows (including all inserted rows). The function returns True if no errors were encountered, and False otherwise.
Examples
For the range illustrated in the original question, the call would look like this:
SplitRows Range("A2:C2"), 2, ","
If the same table started in F5 instead of A1, and if the data in column G (i.e. the data that would fall in column B if the table started in A1) was separated by Alt-Enters instead of commas, the call would look like this:
SplitRows Range("F6:H6"), 2, vbLf
If the table contained the row header plus 10 rows of data (instead of 1), and if it started in F5 again, the call would look like this:
SplitRows Range("F6:H15"), 2, vbLf
If there was no certainty about the number of rows, but we knew that all the valid rows are contiguous and always have a value in column H (i.e. the 3rd column in the range), the call could look something like this:
SplitRows Range("F6:H1048576"), 2, vbLf, 3
In Excel 95 or lower, you would have to change "1048576" to "16384", and in Excel 97-2003, to "65536".

Using VBA to Read AutoFilter Criteria

I am working with an excel workbook where I want to find all unique values in a column.
I have code that works by looping through all the rows and for each row looping through a collection of values seen so far and checking if I've seen it before.
It works like this.
Function getUnique(Optional col As Integer) As Collection
If col = 0 Then col = 2
Dim values As Collection
Dim value As Variant
Dim i As Integer
Dim toAdd As Boolean
i = 3 'first row with data
Set values = New Collection
Do While Cells(i, col) <> ""
toAdd = True
For Each value In values
If Cells(i, col).value = value Then toAdd = False
Next value
If toAdd Then values.Add (Cells(i, col).value)
i = i + 1
Loop
Set getUnique = values
End Function
However, Excel AutoFilter is able to find these values much faster. Is there a way to filter and then read the unique values?
I've tried using the AutoFilter.Filters object but all of the .ItemX.Criteria1 values have a "Application-defined or object-defined error" (found using a watch on ActiveSheet.AutoFilter.Filters).
This isn't quite doing what you describe, I think it's processing it less-efficiently because it's checking every cell against every value.
I think this is probably inefficient, because as the values collection grows in length, the second loop will take longer to process.
You could get some improvement if you exit your nested For early:
Do While Cells(i, col) <> ""
For Each value In values
If Cells(i, col).value = value Then
toAdd = False
Else:
values.Add (Cells(i, col).value)
Exit For '### If the value is found, there's no use in checking the rest of the values!
End If
Next value
i = i + 1
Loop
But I think a Dictionary may give you performance improvement. This way, we don't need to loop over the collection, we just make use of the dictionary's .Exists method. If it doesn't exist, we add to the collection, if it does, we don't. Then the function still returns the collection of uniques.
Function getUnique(Optional col As Integer) As Collection
If col = 0 Then col = 2
Dim values As Object
Dim value As Variant
Dim i As Integer
Dim toAdd As Boolean
Dim ret as New Collection
i = 3 'first row with data
Set values = CreateObject("Scripting.Dictionary")
With Cells(i, col)
Do While .Value <> ""
If Not values.Exists(.Value)
values(.Value) = 1
ret.Add(.Value) '## Add the item to your collection
Else
'## Count the occurences, in case you need to use this later
values(.Value) = values(.Value) + 1
End If
i = i + 1
Loop
Set getUnique = ret
End Function
The AdvancedFilter method may come in handy here and produce cleaner, easier to maintain code. This will work so long as you are calling this Function from another VBA module and not from a cell.
Function getUnique(Optional col As Integer) As Collection
If col = 0 Then col = 2
Dim values As Collection
Dim value As Variant
Dim i As Integer
i = 3 'first row with data
Range(Cells(i, col), Cells(Rows.Count, col).End(xlUp)).AdvancedFilter xlFilterCopy, CopyToRange:=Cells(1, Columns.Count)
Set values = New Collection
Dim cel As Range
For Each cel In Range(Cells(1, Columns.Count), Cells(1, Columns.Count).End(xlDown))
values.Add cel.value
Next
Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Clear
Set getUnique = values
End Function
Tested with this sub:
Sub Test()
Dim c As Collection
Set c = getUnique(4)
For i = 1 To c.Count
Debug.Print c.Item(i)
Next
End Sub

Not looping through array to match values

For some reason my code isn't working, I've used this type of code a thousand times and for whatever reason it's not matching.. When the column is blank however it does seem to match? Any suggestions on how I can change this or even improve this as I do realise 140,000 records is quite a lot!
Dim name1(140000) As String, name2(140000) As String, answer(140000) As String
For i = 1 To 140000
name1(i) = ActiveWorkbook.Worksheets("Sheet0").Cells(i, 1).value
name2(i) = ActiveWorkbook.Worksheets("Sheet1").Cells(i, 6).value
answer(i) = ActiveWorkbook.Worksheets("Sheet0").Cells(i, 13).value
If name1(i) = name2(i) Then
answer(i) = "yes"
End If
Next
Hi thanks for this, the problem being though the values are changing, so the name in sheet 1 might be in in "A1" but then in sheet 2 be in "F12" and then next week could be in "F14" so its just a way of using the code to update accordingly, also used your vba and still no luck :( – Calum 9 mins ago
A formula is the right way to go. You can use COUNTIF to check for the existence. Put this formula in cell M1 and pull it down.
=IF(COUNTIF($F$1:$F$14000,A1)>0,"Yes","No")
However if you still want to use code, try this (Untested)
Sub Sample()
Dim name1 As Variant, name2 As Variant, answer(1 To 14000) As String
Dim ws As Worksheet
Dim i As Long
With ThisWorkbook
name1 = .Worksheets("Sheet0").Range("A1:A14000").Value
name2 = .Worksheets("Sheet1").Range("F1:F14000").Value
For i = 1 To 14000
If IsInArray(name1(i, 1), name2) Then answer(i) = "Yes" Else answer(i) = "No"
Next i
.Worksheets("Sheet1").Range("M1").Resize(UBound(answer), 1).Value = _
Application.WorksheetFunction.Transpose(answer)
End With
End Sub
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
You are first assigning a value to answer(i) from the Worksheet and then assigning the Yes value if it matches.
However this value gets assigned to answer() not to the Cell.
you need to change:
answer(i) = "yes"
to
ActiveWorkbook.Worksheets("Sheet0").Cells(i, 13).Value = "yes"
and remove answer() completely.
The better way would be this:
=IF(A1=F1;"Yes";"No")

Excel VBA: CountIf (value criterion) AND (color criterion)

I am trying to count the number of cells in a range that has the same color as a reference cells, IF the corresponding cell in another range has the correct value criterion. For example:
If (A1 < 350) and (B1 has the same color as a reference cell), then count 1.
Loop over rows 1 to 15
It is essentially the same problem as the question posted here:
http://www.mrexcel.com/forum/excel-questions/58582-countif-multiple-criteria-one-being-interior-color.html
Unfortunately, it seems that the ExtCell.zip file no longer exit. Hence, I could not simply replicate the given solution. I tried to follow the same approach using the SUMPRODUCT function and I wrote a function for comparing cell color, but it did not work. I got the error "A value used in the formula is of the wrong data type." My code is as follow. I am using Excel 2007 on Windows 7. Any help is appreciated. Thanks!
=SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))
The formula above is keyed into a cell. B57:B65 contain some numerical values, while D57:D65 are colored cells. D307 is the reference cell with the correct color.
'' VBA function ColorCompare
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim CallerCols As Long 'find out the number of cells input by the user
'so as to define the correct array size
With Application.Caller
CallerCols = .Column.Count
End With
ReDim TFresponses(1 To CallerCols)
Dim Idx As Long
Idx = 1
For Each rCell In compareCells
If rCell.Interior.ColorIndex = refCell.Interior.ColorIndex Then
TFresponses(Idx) = 1
Idx = Idx + 1
Else
TFresponses(Idx) = 0
Idx = Idx + 1
End If
Next rCell
ColorCompare = TFresponses
End Function
There are a couple of issues in your code
You need to determine the size of compareCells, not the caller cell
You are considering columns, should be Rows (or Rows and Columns for maximum flexability)
There are a few optimisations you can make
Here's a refactored version of your Function
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range, rRw As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim rw As Long, cl As Long
Dim clr As Variant
clr = refCell.Interior.ColorIndex
ReDim TFresponses(1 To compareCells.Rows.Count, 1 To compareCells.Columns.Count)
rw = 1
For Each rRw In compareCells.Rows
cl = 1
For Each rCell In rRw.Cells
If rCell.Interior.ColorIndex = clr Then
TFresponses(rw, cl) = True
End If
cl = cl + 1
Next rCell
rw = rw + 1
Next rRw
ColorCompare = TFresponses
End Function
Note that while this will return a result for any shaped range, to be useful in SumProduct pass it a range either 1 row high or 1 column wide - just as your sample formula does.
Try this (updated for given formula: =SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))):
Sub test()
i = 57
While Not IsEmpty(Cells(i, 1))
If Cells(i, 2) < 350 And Cells(i, 4).Interior.ColorIndex = Cells(307, 4).Interior.ColorIndex Then 'replace with your reference cell
count = count + 1
End If
i = i + 1
Wend
End Sub