I'm new to VBA and struggling with the piece of code.
I need to find the first non-empty row where the conditions are simultaneously met. There must be text in col B and C and number in col D and G (all 4 conditions must be met).
I'd very grateful for help
s
write like below code using and if & and note:lastrow is end of column values.
for i = 1 to lastrow
if cells(i,"b")<>"" and cells(i,"c")<>"" and isnumber(cells(i,"d"))= true and isnumber(cells(i,"g"))= true then
'do something
end if
next i
you may want to nest SpecialCells() method as follows:
Sub main()
With Worksheets("Conditions") '<--| change "Conditions" to your actual worksheet name
With .Range("B1", .Cells(.Rows.Count, "B").End(xlUp)) '<-- refer to column "B" cells down to last non empty one
With .SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues) '<-- refer to its "text" cells only
With .Offset(, 1).SpecialCells(XlCellType.xlCellTypeConstants, xlTextValues) '<-- refer to adjacent column "text" cells only
With .Offset(, 1).SpecialCells(XlCellType.xlCellTypeConstants, xlNumbers) '<-- refer to adjacent column "number" cells only
With .Offset(, 1).SpecialCells(XlCellType.xlCellTypeConstants, xlNumbers) '<-- refer to adjacent column "number" cells only
MsgBox .Cells(1, 1).row '<--| get first "multifiltered" cells row
End With
End With
End With
End With
End With
End With
End Sub
you may need to add test before each SpecialCells() to check that "current" column actually has some text/numbers value, using a mix of Count() and CountA() method
Related
I have a column that has many blanks and entries. I want to take the entries (ignoring the blanks) and move them over to the right once and down twice replacing the contents. I have a feeling you would use the offset function, however I don't know how to write this in VBA. I've only used offset as a formula. Any help would be appreciated...
here's a one liner:
Range("A:A").SpecialCells(xlCellTypeConstants).Offset(2, 1).FormulaR1C1 = "=R[-2]C[-1]" '<--| change "A:A" to actual column index
or, should your "not blank" cells derive from formulas in the cells:
Range("A:A").SpecialCells(xlCellTypeFormulas).Offset(2, 1).FormulaR1C1 = "=R[-2]C[-1]"
First you need to create a loop, that moves through all the values of your range. There many ways to create loops, but here is one example:
'find last row of range
lastrow = ActiveSheet.UsedRange.Rows.Count
'Loops through the values from 2 to the last row of range
For x=2 to lastrow
Next x
Then I recommend to loop through the range and check each cell value for your criteria using the IF function:
'Checks for blank value in column A. If not blank
If Cells(x, 1).Value <> "" then
'Do Something
End IF
Now in order to copy all values in a new range, just set the values of the old and new cell equal:
'Moves value from column A to column B and two cells down
Cells(x+2, 2).Value = Cells(x, 1).Value
In summary your code would look something like this:
Sub MoveValue ()
lastrow = ActiveSheet.UsedRange.Rows.Count
For x=2 to lastrow
If Cells(x, 1).Value <> "" then
Cells(x+2, 2).Value = Cells(x, 1).Value
End IF
Next x
End Sub
I'm trying to setup a VBA code that loops through each cell in column M and returns the value of Column L if the cell contains a number, and goes through an index/match function if Column L doesn't contain a number. Then if the index/match doesn't find what it's looking for, it goes through another vlookup. I'm having trouble with the syntax of the third part of this (the vlookup at the end). I'm not sure if it should be another Else statement or an if statement or an ISerror or something different entirely. Right now I have it set up as the second if/else. I'm also wondering if I will have problems due to the fact that the index/match function has text as the input and should return a number. Any suggestions/advice on this is much appreciated. Below is what I have so far.
Sub Ranking_2()
Dim cell As Range, rng As Range
Set rng = Range("L2:L120")
For Each cell In rng
If WorksheetFunction.IsNumber(cell.Value) Then
cell.Offset(0, 1).Value = cell.Value
Else: cell.Offset(0, 1).Value = WorksheetFunction.Index(ThisWorkbook.Sheets(1).Range("K:K"), WorksheetFunction.Match(cell.Offset(0, 1) & cell.Offset(0, 5), ThisWorkbook.Sheets(1).Range("A:A") & ThisWorkbook.Sheets(1).Range("H:H"), 0))
If:cell.Offset(0,1).Value= WorksheetFunction.IsError(
Else: cell.Offset(0, 1).Value = WorksheetFunction.VLookup(cell.Offset(0, -11), ThisWorkbook.Sheets(2).Range("A1:D136"), 3, 0)
End If
Next
End Sub
you may want to adopt these changes to your code
Option Explicit
Sub Ranking_2()
Dim cell As Range
Dim lookUp1Sht As Worksheet
Dim lookUp2Rng As Range
Dim val1 As Variant
Set lookUp1Sht = ThisWorkbook.Worksheets("LookUp1Sht") '<--| set the worksheet you're making the first lookup
Set lookUp2Rng = ThisWorkbook.Worksheets("LookUp2Sht").Range("A1:C136") '<--| since you're this range returning column "C" value it suffices limiting it to column "C"
For Each cell In Range("L2:L120").SpecialCells(xlCellTypeConstants) '<--| limit looping through wanted range not blank cells only
With cell '<--| reference current cell
Select Case True
Case IsNumeric(.Value) '<--| if current cell value can be evaluated as "number"...
.Offset(0, 1).Value = CDbl(.Value)
Case Not IsError(LookUp1(lookUp1Sht, .Offset(0, 1).Value, .Offset(0, 5).Value, val1)) '<-- if "first" lookup doesn't return an "error"...
.Offset(0, 1).Value = val1 '<--| then write the 3rd argument passed from LookUp1() function
Case Else '<-- if all preceeding "cases" failed...
.Offset(0, 1).Value = Application.VLookup(.Offset(0, -11), lookUp2Rng, 3, 0) '<-- write "second" lookup return value
End Select
End With
Next
End Sub
Function LookUp1(sht As Worksheet, val1 As Variant, val2 As Variant, val As Variant) As Variant
Dim f As Range
Dim firstAddress As String
With sht '<--| reference passed worksheet
Set f = .Range("A:A").Find(what:=val1, LookIn:=xlValues, lookat:=xlWhole) '<-- look for first passed value in its column "A"
If Not f Is Nothing Then '<--| if found...
firstAddress = f.Address '<--| store found cell address to stop subsequent FindNext() loop upon wrapping back to it
Do '<--| loop
If f.Offset(, 7).Value = val2 Then '<--| if corresponding value in column "H" matches val2...
val = .Cells(f.row, "K") '<-- set 3rd argument to value in column "K" corresponding to the "double" match
Exit Function '<--| exit function
End If
Set f = .Range("A:A").FindNext(f) '<-- go on looking for val1 in column "A"
Loop While f.Address <> firstAddress '<-- stop looping upon wrapping back on first cell found
End If
End With
LookUp1 = CVErr(xlErrValue) '<-- if no "double" match occurred then return "#VALUE!" error
End Function
please note that:
change "LookUp1Sht" and "LookUp2Sht" to your actual worksheets names
Match and LookUp Application functions handle possible errors without halting the macro and simply returning the error value
This I only used in .Offset(0, 1).Value = Application.VLookup(.Offset(0, -11)..., so that if the "last chance lookup" ever returned an error you would have it written in your .Offset(0,1) cell
use SpecialCells() method to return a filtered group of the range you call it on: for instance using xlCellTypeConstants as its Type parameter you'd get back not empty cell only
use IsNumeric() function instead of [WorksheetFunction.IsNumber()[(https://msdn.microsoft.com/en-us/library/office/ff840818(v=office.15).aspx) since the former will recognize string "5" as a number, while the latter would not
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 6 years ago.
Improve this question
I am looking for some VBA help to clean up a Worksheet by deleting rows of data I do not need and keeping the rows of data I do based on multiple criteria.
I want to be able to keep any Row that equals "Subtotal:" in Column A and any Row that contains a number in column C while deleting all other rows that do not match that criteria.
Before Cleanup
Desired Result Requested
I wrote a function which should be able to get the job done.
So you can call the function from a sub and pass the column number you want to test (1 for "A"), the value you would like to test ("" for blank), the name of the worksheet you would like to test. The final argument is a Boolean value and if true it will delete on matching the value in the criteria, if not it will delete on anything else.
Function DeleteCol(iCol As Integer, strCriteria As String, strWSName As String, bPositive As Boolean)
Dim iLastCol As Integer
Dim wsUsed As Worksheet
Set wsUsed = ThisWorkbook.Worksheets(strWSName)
iLastRow = wsUsed.Cells(Rows.Count, iCol).End(xlUp).Row
For i = iLastRow To 1 Step -1
With wsUsed.Cells(i, iCol)
If bPositive Then
If .Value = strCriteria Then .EntireRow.Delete
Else
If .Value <> strCriteria Then .EntireRow.Delete
End If
End With
Next i
End Function
So to do what you requested above you could do:
Sub Delete()
Call DeleteCol(1, "Subtotal:", "CoolSheetName", False)
Call DeleteCol(3, "", "CoolSheetName", True)
End Sub
you may want to try the following (commented) code:
Option Explicit
Sub main()
With Worksheets("MySheetName") '<--| change "MySheetName" to your actual sheet name
With Intersect(.UsedRange, .Columns("A:C"))
.AutoFilter Field:=1, Criteria1:="<>Subtotal" '<--| filter column "A" cells not containing "Subtotal"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1).Resize(.rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete '<--| delete any filtered cell row
.AutoFilter '<--| show all data back
With .Offset(1, 2).Resize(.rows.Count - 1, 1) '<--| consider column "C" cell from header row (excluded) down
DeleteRows .Cells, xlCellTypeConstants, xlTextValues '<--| delete any "constant text" cell row
DeleteRows .Cells, xlCellTypeFormulas, xlTextValues '<--| delete any "formula text" cell row
DeleteRows .Cells, xlCellTypeBlanks, xlTextValues '<--| delete any "blank" cell row
End With
End With
End With
End Sub
Sub DeleteRows(rng As Range, cellType As XlCellType, cellsValue As XlSpecialCellsValue)
Dim f As Range
Set f = rng.SpecialCells(cellType, cellsValue)
If Not f Is Nothing Then f.EntireRow.Delete
End Sub
I have a range of four cells. The furthest left cell (column A) is a unique value. The next three cells to the right are populated with formulas. Columns B and C are Vlookups that pull values from sheet 2 when column A is populated (otherwise the cells have a value of ""). Column D populates with the current date when a value is put into Column A (otherwise the cells have a value of "" as well).
What I'm trying to do is run a macro when a unique value is put into column A that will kill the formulas in B,C,D and keep their values. Then it automatically selects the cell in the subsequent row in column A. A3 is fixed which is why I used the End(xlDown) method and then Activecell.Offset.
This is what I have that is bombing Excel when it runs:
Private Sub Worksheet_Change(ByVal Target As Range)
Range(ActiveCell, ActiveCell.Offset(0, 3)).Value = Range(ActiveCell, ActiveCell.Offset(0, 3)).Value
Range("A3").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End Sub
Always turn off event handling before changing a value in a Worksheet_Change. If you don't, the routine will try to run on top of itself.
If a change in column A is what dictates the need to remove formulas then restrict the processing to when there is a change in column A.
ActiveCell is not a good choice here. Use Target instead. Target may be one or more than one cell.
Look for the first empty cell in column A from the bottom up, not the top down.
Use error control to ensure that the VLOOKUPs have returned values, not errors.
Here is some general code that should get you started.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("A")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("A"))
If Not IsError(rng.Offset(0, 1)) Then
rng.Resize(1, 3) = rng.Resize(1, 3).Value
End If
Next rng
With Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
'optionally put in new VLOOKUP formulas in column B and C
'.Offset(0, 1).FormulaR1C1 = "=VLOOKUP(RC1, Sheet2!C1:C3, 2, FALSE)"
'.Offset(0, 2).FormulaR1C1 = "=VLOOKUP(RC1, Sheet2!C1:C3, 3, FALSE)"
.Select
End With
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
I have data in 3 Columns
A B & C, in which a Filter is active on column A, I want to apply a code so that the formula is applied on Column C - from the 2nd visible row till the last visible row.
Here is the code I have written, However It doesn't work if I change the Range("C:C") or Range("C2:C")
Sub Test()
Dim rng As Range
Range("C1").Select
Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("**C2:C2000**"))
rng.Select
Selection.Formula = "=RC[-1]+RC[-2]"
End Sub
With an active AutoFilter method, presumably your first row contains column header labels and the data is below that. The Range.CurrentRegion property is a better fit for this situation than the Worksheet.UsedRange property.
The Range.SpecialCells method with xlCellTypeVisible will reference the visible cells. I find that the worksheet's SUBTOTAL function provides a nice non-destructive method of seeing iof there are visible cells before trying to access them.
A few With ... End With statements will help you progressively isolate the cells you are looking for.
Sub test()
'note that not a single var is necessary
With Worksheets("Sheet1") '<~~ surely you know what worksheet you are on
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) '<~~one row down
If CBool(Application.Subtotal(103, .Cells)) Then
'there are visible cells
With .Columns(3).SpecialCells(xlCellTypeVisible)
.Cells.FormulaR1C1 = "=RC[-1]+RC[-2]"
End With
End If
End With
End With
End With
End Sub
I've used the Range.FormulaR1C1 property (as opposed to your original Range.Formula property) single you were using xlR1C1 not xlA1 formula syntax.