I have a For loop & a For Each loop in VBA, where I am searching for a string within the content of each cell in the loop using Offset:
Using For Each:
Lastrow = ActiveSheet.Range("A2").End(xlDown).Row
Set Myrange = ActiveSheet.Range("M2:M" & Lastrow)
countrows = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For Each Cell In Myrange
If strPattern <> "" Then
If Cell.Offset(0, 31) <> "Fizz" Then
strInput = Cell.Value
Using For:
countrows = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For i = 1 To countrows
Range("AK" & i).Select
check_value = ActiveCell
If ActiveCell.Offset(0, 7) <> "Buzz" Then
ActiveCell.EntireRow.Copy
In the bottom example, I must use ActiveCell.Offset. Using Cell.Offset or even Cell.Offset.Value throws an "Object Required" error.
Why is this the case?
In the bottom example you haven't defined what Cell is so VBA has no clue as to what you're trying to do. Cell isn't a special word - it is a variable in the top example
A better way to write your bottom statement would be to use a With instead of the ActiveCell and Select
countrows = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For i = 1 To countrows
With Range("AK" & i)
check_value = .Value2
If .Offset(0, 7) <> "Buzz" Then
.EntireRow.Copy
End If
End With
Next i
In first loop Cell is a Range object.
In second one Cell is Nothing, you must assign a Range object to it i.e.:
Set Cell = Range("AK" & i)
Btw, do you declare your variables?
Related
I am trying to bring a formula inside my vba code and I am getting an error inside it. Please have a look into the code and kindly share your thoughts.
This is my excel function that was written in VBA Code :
GetUniqueCount(Range,Value)
And here is the VBA Code trying to make use of it :
Sheets("sheet2").Activate
With ThisWorkbook.Sheets("sheet2").UsedRange
lastrow = .Rows(.Rows.Count).Row
End With
For i = 14 To lastrow
check = Range("h" & i).Value
If check <> "" Then
Range("I" & i).Value = WorksheetFunction.GetUniqueCount(sheet1!.Range("A1:B100"), check)
Else
Range("I" & i).Value = ""
Next
The range for the function comes from a different sheet. How do I write it in VBA?
This is the function for it :
Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
If x(i, 1) = Lookup Then
dict.Item(x(i, 1) & x(i, 2)) = ""
End If
Next i
GetUniqueCount = dict.Count
End Function
You have other possible errors in your code, unqualified Range, etc.
Since your Function GetUniqueCount is not Excel's built in WorksheetFunction, but your own UDF, you don't need to call it with WorksheetFunction.GetUniqueCount but just GetUniqueCount.
Try the code below:
Option Explicit
Sub Test()
Dim LastRow As Long, i As Long
Dim check As String
With ThisWorkbook.Worksheets("sheet2")
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
Dim Rng As Range
Set Rng = Worksheets("sheet1").Range("A1:B100")
For i = 14 To LastRow
check = .Range("H" & i).Value
If check <> "" Then
.Range("I" & i).Value = GetUniqueCount(Rng, check)
Else
.Range("I" & i).Value = ""
End If
Next i
End With
End Sub
There is no worksheet function by the name of GetUniqueCount. If this is a function you have in your code then the way to call it would be like this:-
Range("I" & i).Value = GetUniqueCount("Sheet1".Range("A1:B100"), check)
This code presumes that your function is either on the same code sheet as the calling procedure or declared public. It must take two arguments, the first of which must be a range, the second of the same data type as check. If you didn't declare check (which isn't a good idea) then its data type will be Variant.
I try to find row of min value in range exept row has special word.
For EX:
Now, I would like to find row of fruits which has min number exept "Watermelon".
And result should be is 5 (row of banana)
My idea is find second lowest value with
SecLowVal = objExcel.WorksheetFunction.Small(Range("B2:B6"),2)
and then we will find row of this value
For Each rngCell In Range("B2:B6")
If rngCell.Value = SecLowVal Then
Row = rngCell.Row
Exit For
End If
Next rngCell
msg(Row)
But in case:
It will be wrong, I don't know is there any function or the way to do like that find row of min value except row has special word
Use this formula.
=CELL("row",INDEX(B2:B6,MATCH(MIN(IF(A2:A6<>"Watermelon",B2:B6,"")),B2:B6,0)))
Press CTRL+SHIFT+ENTER to evaluate the formula as it is an array formula.
Edited update formula based on your comment.
=CELL("row",INDEX(B2:B6,MATCH(MIN(IF(A2:A6<>"Watermelon",B2:B6,"")),IF(A2:A6<>"Watermelon",B2:B6,""),0)))
Press CTRL+SHIFT+ENTER to evaluate the formula as it is an array formula.
=========================== VBA Function ============================
Public Function MinBasedOnCondition(InRange As Range, valRange As Range, ConditionItem As String) As Variant
Dim MyCell As Range
Dim ValueArray()
Dim MyArray()
Dim CelCount, inc, MinVal, i As Long
Dim Condition As String
Dim ArrItems, Result
Condition = ConditionItem
CelCount = Application.CountIf(InRange, "<>" & Condition)
ReDim ValueArray(CelCount)
inc = 1
For Each MyCell In InRange
If MyCell.Value <> Condition Then
ValueArray(inc) = MyCell.Offset(0, 1).Value
inc = inc + 1
End If
Next
ArrItems = ""
For i = 1 To CelCount
ArrItems = ArrItems & ValueArray(i) & ", "
Next
ArrItems = Left(ArrItems, Len(ArrItems) - 2)
MyArray = Array(ArrItems)
MinVal = Evaluate("Min(" & Join(MyArray, ",") & ")")
For Each MyCell In valRange
If MyCell.Offset(0, -1).Value <> Condition Then
If MyCell.Value = MinVal Then
Result = MyCell.Row
Exit For
End If
End If
Next
MinBasedOnCondition = Result
End Function
Use in worksheet
With Range AutoFilter() and WorksheetFunction Min() methods, code gest shorter, with neither loops nor variables to be declared:
Function FindMinFilterWaterMelon() As Long
With Range("A1", Cells(Rows.count, "A").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>*Watermelon" ' show all values in range, except "Watermelon"
With .Offset(, 1).SpecialCells(xlCellTypeVisible) '<--| reference column "B" filtered cells
FindMinFilterWaterMelon = .Find(WorksheetFunction.Min(.Cells), , xlValues, xlWhole, xlByRows, xlNext).row '<--| get row of cell with minimum value
End With
.Parent.AutoFilterMode = False
End With
End Function
a possible enhancement of which could be passing it fruit to discard:
Function FindMinFilterWaterMelon(fruitToDiscard As String) As Long
With Range("A1", Cells(Rows.count, "A").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>*" & fruitToDiscard ' show all values in range, except passed fruit to discard
With .Offset(, 1).SpecialCells(xlCellTypeVisible) '<--| reference column "B" filtered cells
FindMinFilterWaterMelon = .Find(WorksheetFunction.Min(.Cells), , xlValues, xlWhole, xlByRows, xlNext).row '<--| get row of cell with minimum value
End With
.Parent.AutoFilterMode = False
End With
End Function
I would try to approach it in a different way. First I would filter out the "Watermelon" row.
Then loop through the Range containing only visible cells (using the SpecialCells(xlCellTypeVisible))), and finding the Minimum Value.
Code
Sub FindMinFilterWaterMelon()
Dim LastRow As Long, RowFound As Long
Dim MinVal, Rng As Range, cell As Range
Range("A1:B1").AutoFilter
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
' show all values in range, except "Watermelon"
With Range("A1:B" & LastRow)
.AutoFilter Field:=1, Criteria1:="<>*Watermelon*"
End With
' set range only to visible cells
Set Rng = Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
MinVal = 100000 ' init value of MinVal
' loop through all cells in Range visible cells and look for minimum value
For Each cell In Rng.Cells
If cell.Value < MinVal Then
MinVal = cell.Value
RowFound = cell.Row
End If
Next cell
MsgBox "Min value of " & MinVal & " was found at row " & RowFound
End Sub
I'm trying to add a Vlookup piece to a long macro that I'm working on to eliminate some daily data manipulation work.
Essentially everyday I have four new columns of data that I compare to the day befores, using vlookup. The four new columns sit in columns C-F and the old data in columns M-P. I vlookup column D against column M, with the formula in column G.
I'm running into a problem of how to be flexible with the range I give the macro to use each day as I don't want to constantly change it. The amount of rows will fluctuate between 10,000-30,000.
Here is my code- I'm probably thinking about this all wrong.
Sub Lookup()
Dim i, LastRow
Set i = Sheets("data").Range("F5").End(xlUp)
If Cells(i, "F5").Value <> "" Then
Range(i, "G").Value = WorksheetFunction.VLookup(Cells(i, "D"), Range("N").End(xlDown), 1, False)
End If
End Sub
Give this a go
Sub Sheet2_Button1_Click()
Dim Rws As Long, rng As Range, Mrng As Range, x
Rws = Cells(Rows.Count, "D").End(xlUp).Row
Set rng = Range(Cells(1, "G"), Cells(Rws, "G"))
Set Mrng = Range("M1:M" & Rws)
rng = "=IFERROR(VLOOKUP(D1, " & Mrng.Address & ",1,0),""Nope"")"
'----------If you want it to be just values uncomment the below line--------------
' rng.Value=rng.Value
End Sub
You have some backwards range references. I can't speak to the vlookup call, but you can start by looking at this part:
If Cells(i, "F5").Value <> "" Then
Range(i, "G").Value = WorksheetFunction.VLookup(Cells(i, "D"), Range("N").End(xlDown), 1, False)
End If
Try changing it to this to fix the range declarations:
If Range("F" & i).Value <> "" Then
Range("G" & i).Value = WorksheetFunction.VLookup(Range("D" & i), Range("N").End(xlDown), 1, False)
End If
I have a problem with my code about delete blank rows. It just has to delete some rows not all blank rows and rows value "0". I don't wanna use .SpecialCells(xlCellTypeBlanks) as some threat on SO forum.
Dim R As Integer
R = Range("CuoiNKC").Row - 1
Dim DelCell As Range
Dim DelRange As Range
Set DelRange = Range("J9:J" & R)
For Each DelCell In DelRange
If DelCell.Value = "0" Or DelCell.Formula = Space(0) Then
DelCell.EntireRow.Delete
End If
Next DelCel
Why don't you use Range AutoFilter Method instead of looping.
Assuming you have the correct value of DelRange in your code, try this:
DelRange.AutoFilter 1, AutoFilter 1, "=0", xlOr, "=" 'filtering 0 and space
DelRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete xlUp 'delete visible cells
ActiveSheet.AutoFilterMode = False 'remove auto filter mode
Btw, if you want to stick with your logic, you need to iterate the rows backward.
You can only do that using the conventional For Next Loop. Again assuming value of R is correct.
For i = R To 9 Step -1
If Range("J" & i).Value = "0" Or Range("J" & i).Value = " " Then
Range("J" & i).EntireRow.Delete xlUp
End If
Next
I was wondering if someone would be kind enough to suggest some corrections to the indicated line in the script below.
It is throwing up "Object variable or With block variable not set" alarm.
I can only guess this means the "CellFound" range is not being set and that the problem lies within that line.
The "CellFound" variable is meant to find and store the location of a cell.value<=25 within DateRng for use by the following condition
To re-iterate, the entire script is to carry out the following tasks:
Locate a range that is located between 2 cells containing specific strings (DateRng)
Loop within this range for cells (i) that have a value <=25
Compare two other cells which are offset to "i"
Export a range of rows centered around "i" to different sheets pending the outcome of the above condition.
Thanks for your time.
Sub ReportCells()
Dim LR As Long, i As Long
Dim j, k As Long
Dim StartDate, FinishDate As String
Dim Sh As Worksheet: Set Sh = Sheets("Full chart and primary cals")
Dim CellFound As Range
'Range Extraction Script
'Search location and values
LookupColumn = "B"
StartDate = "2013.01.02 20:00"
FinishDate = "2013.01.09 20:00"
'Find Lower Limit
For j = 1 To 30000
If Sh.Range(LookupColumn & j).Value = FinishDate Then FinishDateRow = j
Next j
'Find Upper Limit
For k = FinishDateRow To 1 Step -1
If Sh.Range(LookupColumn & k).Value = StartDate Then StartDateRow = k - 1
Next k
'Set Range once located
Dim DateRng As Range: Set DateRng = Sh.Range(LookupColumn & StartDateRow & ":" & LookupColumn & FinishDateRow)
MsgBox DateRng.Address
'Find Cell
With DateRng
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To LR
** Set CellFound = .Find(Sh.Range("M:M").Value <= 25, LookIn:=xlValues) **
MsgBox CellFound.Address
If Not CellFound Is Nothing And CellFound.Offset(0, -5).Value < CellFound.Offset(-1, -5).Value Then .Offset(-3, 0).Resize(10, 1).EntireRow.Copy Destination:=Sheets("DownT").Range("A" & Rows.Count).End(xlUp).Offset(2)
If Not CellFound Is Nothing And CellFound.Offset(0, -5).Value > CellFound.Offset(-1, -5).Value Then .Offset(-3, 0).Resize(10, 1).EntireRow.Copy Destination:=Sheets("UpT").Range("A" & Rows.Count).End(xlUp).Offset(2)
Next i
End With
End Sub
EDIT: The cell selection and copy block has been modified to the code below. It seems that the value<=25 set range commands are not executing as they should be. They are definately filtering data but on what column I am not sure. The block is returning a range of cells of the correct size. But only one range (instead of around 20 or so). And of the wrong range of rows :S I guess any progress is progress regardless of if it's right or wrong
With Sheets("Full chart and primary cals")
LR = Range("B" & Rows.Count).End(xlUp).Row
'For i = Range("M" & Rows.Count).End(xlUp).Row To 1 Step -1
For i = 1 To LR
With DateRng.Range("M" & i)
If Range("M" & i).Value <= 25 Then Set CellFound = Sh.Range("M" & i)
If Not CellFound Is Nothing Then .Offset(-5, 0).Resize(10, 1).EntireRow.Copy Destination:=Sheets("DownT").Range("A" & Rows.Count).End(xlUp).Offset(2)
End With
Next i
End With
The solution to the problem........
'Loop through sheet looking for cells
LR = .Range("B" & Rows.Count).End(xlUp).Row
For i = 10 To LR
'Find cells in "M" and store thier reference in Cellref
If .Range("M" & i).Value <= 25 Then Set Cellref = .Range("M" & i) Else Set Cellref = .Range("Z15")
'Find if Cell ref is contained within DateRange and store result as bool
If Not Application.Intersect(DateRange, Cellref) Is Nothing Then iSect = True Else iSect = False
'Output cell ranges to the appropriate sheets
If iSect = True And Cellref.Offset(0, -5) < Cellref.Offset(-10, -5) Then _
Cellref.Offset(-3, 0).Resize(10, 1).EntireRow.Copy Destination:=Sheets("DownT").Range("A" & Rows.Count).End(xlUp).Offset(2)
If iSect = True And Cellref.Offset(0, -5) > Cellref.Offset(-10, -5) Then _
Cellref.Offset(-3, 0).Resize(10, 1).EntireRow.Copy Destination:=Sheets("UpT").Range("A" & Rows.Count).End(xlUp).Offset(2)
Next i
From what I can tell from your code you're misusing the Range.Find() function, which will most probably cause it to return Nothing instead of a meaningful range.
Sh.Range("M:M").Value will throw a Type Mismatch error as you cannot use the .Value property of a Range containing multiple cells. As this error is contained within the arguments of your .Find function it's entirely possibly it's just being ignored but it will still cause .Find to return Nothing.
Even were that not the case Sh.Range("A1") <= 25 evaluates to either True or False (Depending on the value of A1) and the Find function would then search DateRng for the first instance of True or False within that range.
I'd recommend some further reading on how the Range.Find function works as it may not be suitable for the task you have in mind.