In the attached image containing my data i am trying to do the following :
1)To select all rows and individual cells from column I through the end(column BQ) if the value in column C = "DOSH"
2) Once i select those cells(I through BQ) for each cell i want to use a formula
"=R(-2)C/R(-3)C"
I started with the following code but it selects the entire row and not just column I through BQ. I am also not sure where i should include the formula.
Sub SelRows()
Dim ocell As Range
Dim rng As Range
For Each ocell In Range("C:BQ")
If ocell.Value = "DOSH" Then
If rng Is Nothing Then
Set rng = ocell.Select
Else
Set rng = Union(rng, ocell.EntireRow)
End If
End If
Next
If Not rng Is Nothing Then rng.Select
Set rng = Nothing
Set ocell = Nothing
End Sub
Can you try this? I'm not sure about your formula so that may need adjusting. Assumed your data start in row 2.
Sub SelRows()
Dim ocell As Range
Dim rng As Range
For Each ocell In Range("C2", Range("C" & Rows.Count).End(xlUp))
If ocell.Value = "DOSH" Then
If rng Is Nothing Then
Set rng = Range(Cells(ocell.Row, "I"), Cells(ocell.Row, "BQ"))
Else
Set rng = Union(rng, Range(Cells(ocell.Row, "I"), Cells(ocell.Row, "BQ")))
End If
End If
Next
If Not rng Is Nothing Then
rng.FormulaR1C1 = ""=iferror(R[-2]C/R[-3]C,"""")""
End If
Set rng = Nothing
Set ocell = Nothing
End Sub
Related
Thank you in advance. New to VBA and trying to teach myself in my spare time. I am hoping someone can provide me some code to build on.
I want to loop through column K and search for each cell in columns A:I. Then I want to select the whole row and cut to another sheet. This is the code I have written, it utilized activecell but as you can imagine I would like to avoid having to click the cell I want to search for every time I execute the Macro. Especially, if I have 150 values in column K.
Sub Lineups()
Dim rng As Range
Set rng = Range("A2:I1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
ac.Interior.Color = 65535
Range("A" & ActiveCell.Row).Resize(1, 9).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
End Sub
Picture of the Data Set is below.
Data Set
Please, try the next code. Not tested, but it should work. Selecting, activating is not ta good habit. It only consumes Excel resources without bringing any benefit. Then, coloring, copying each cell/range during iteration, takes time and makes code slower. The best way is to build Union ranges and color/copy at the end of the code, at once:
Sub Lineups()
Dim ws As Worksheet, rng As Range, ac As Range, rngCol As Range
Dim lastRow As Long, rngCopy As Range, arrRng, i As Long
Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
'lastRow = ws.Range("K" & ws.rows.count).End(xlUp).row 'the last row in column K:K
lastRow = 1501 'if you need last cell in K:K, uncomment the line above and comment this one
Set rng = ws.Range("A2:H" & lastRow)
For i = 2 To lastRow
Set ac = rng.Find(what:=ws.Range("K" & i).value, After:=ws.Range("A2"), LookIn:=xlValues, Lookat:=xlWhole)
If Not ac Is Nothing Then 'if a match has been found:
If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCol = ws.Range("K" & i)
Else
Set rngCol = Union(rngCol, ws.Range("K" & i))
End If
If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCopy = ws.Range("A" & ac.row, ws.cells(ac.row, "i"))
Else
Set rngCopy = Union(rngCopy, ws.Range("A" & ac.row, ws.cells(ac.row, "i")))
End If
End If
Next i
If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K
'Copy the necessary range in sheet "Lineups" and clear the copied range:
Dim wsL As Worksheet, nextRow As Long
Set wsL = Sheets("Lineups")
nextRow = wsL.cells(rows.count, 1).End(xlUp).row + 1
If Not rngCopy Is Nothing Then 'if at least a match has been found:
rngCopy.Copy wsL.cells(nextRow, 1) 'copy the union range at once
rngCopy.ClearContents 'clear contents of the union range at once
End If
End Sub
I am leaving now my office. If something does not work as you need, or you do not understand the code, do not hesitate to ask or specify what is happening against what you need. I will be able to reply after some hours when I will be at home.
Edited:
Please, test the next version and send some feedback:
Sub Lineups_()
Dim ws As Worksheet, rng As Range, rngSearch As Range, ac As Range, rngCol As Range
Dim lastRow As Long, rngCopy As Range, rngExcl As Range, i As Long, k As Long
Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
lastRow = ws.Range("K" & ws.Rows.Count).End(xlUp).Row 'the last row in column K:K
ws.Range("K2:K" & lastRow).Interior.Color = xlNone 'clear interior color to see the changes (you can comment it, if not necessary)
Set rng = ws.Range("A2:H1501")
Set rngSearch = rng 'set a so named search range, adapted by excluding of processed rows
For i = 2 To lastRow
Set ac = rngSearch.Find(what:=ws.Range("K" & i).Value, After:=rngSearch.Cells(1, 1), LookIn:=xlValues, Lookat:=xlWhole)
If Not ac Is Nothing Then 'if a match has been found:
If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCol = ws.Range("K" & i)
Else
Set rngCol = Union(rngCol, ws.Range("K" & i))
End If
If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCopy = ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")):
Set rngExcl = ws.Range("A" & ac.Row) 'set the range to be excluded
Else
Set rngCopy = Union(rngCopy, ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")))
Set rngExcl = Union(rngExcl, ws.Range("A" & ac.Row)) 'build the range to be excluded
End If
End If
'build the string where to search for:
Set rngSearch = InverseIntersect(rngSearch, rngExcl.EntireRow)
Next i
If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K
'Copy the necessary range in sheet "Lineups" and clear the copied range:
Dim wsL As Worksheet, nextRow As Long
Set wsL = ws.Next ' Sheets("Lineups")
nextRow = wsL.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Not rngCopy Is Nothing Then 'if at least a match has been found:
rngCopy.Copy wsL.Cells(nextRow, 1) 'copy the union range at once
rngCopy.ClearContents 'clear contents of the union range at once
End If
MsgBox "Ready..."
End Sub
Function InverseIntersect(bigRng As Range, rngExtract As Range) As Range
Dim rng As Range, rngRow As Range
For Each rngRow In bigRng.rows 'iterate between the range to be processed rows:
If Intersect(rngRow, rngExtract) Is Nothing Then 'if iterated row intersects with range to be extracted:
'creates a range only from rows which do not intersect
If rng Is Nothing Then 'Set the range as the current row
Set rng = rngRow
Else
Set rng = Union(rng, rngRow) 'creates a Union between the previous existing range and the current row
End If
End If
Next
Set InverseIntersect = rng 'set the function as the newly created range
End Function
I have the following code... It should go through my table, picking out where column B has the value 'OSI' and column C has the value 'Notifications'. There are three rows which match this criteria.
From this I want to create a named range called 'Notif' that spans the corresponding columns from D to F for those rows, not including the B and C items.
Set NotifRng = sht.Range(sht.Range("B1"), sht.Range("C" & sht.Rows.Count).End(xlUp))
counter = 0
For Each cell In NotifRng 'loop through the range of features
If cell.Value = "Notifications" And cell.Vaue = "OSI" Then
counter = counter + 1
If counter = 1 Then
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
End If
End If
Next cell
Debug.Print rng.Address
ThisWorkbook.Names.Add "Notif", rng
When I run the above code, only the first row returns, not all three. What am I doing wrong? I am not getting any error messages...
Any help would be very very very much appreciated!
The problem is in If cell.Value = "Notifications" And cell.Vaue = "OSI" Then, because the cell.Value cannot be both "Notifications" and "OSI".
Furthermore, you only need to loop through the first column of the range, thus: For Each cell In notifRng.Columns(1).Cells
The counter variable is not needed, if you check whether rng is assigned or not. At the end it is a good idea to check the rng again, before printing its address - If Not rng Is Nothing Then Debug.Print rng.Address
If this is the input:
Then running this code:
Sub TestMe()
Dim sht As Worksheet
Set sht = Worksheets(1)
Dim notifRng As Range
Set notifRng = sht.Range(sht.Range("B1"), sht.Range("C" & sht.Rows.Count).End(xlUp))
Dim rng As Range
Dim cell As Range
For Each cell In notifRng.Columns(1).Cells
If cell.Value = "OSI" And cell.Offset(columnoffset:=1).Value = "Notifications" Then
If rng Is Nothing Then
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3)))
End If
End If
Next cell
If Not rng Is Nothing Then Debug.Print rng.Address
End Sub
Would deliver this:
$C$3:$E$3,$C$5:$E$5,$C$9:$E$9
This may work for you. It does away with the counter to see if a range has passed and checks the status of the Rng variable instead.
Sub Test()
Dim sht As Worksheet
Dim NotifRng As Range
Dim cell As Range
Dim Rng As Range
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
Set NotifRng = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With
For Each cell In NotifRng 'loop through column B.
If cell.Value = "Notifications" And cell.Offset(, 1) = "OSI" Then 'Check value in column B & C.
If Rng Is Nothing Then 'If Rng doesn't contain a range then set one (columns C & E)
Set Rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else 'If Rng already contains a range(s) then add to it.
Set Rng = Union(Rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
End If
End If
Next cell
ThisWorkbook.Names.Add "Notif", Rng
End Sub
Hmmm - trying to delete my answer as #Vityata explains better, but it's not letting me.
I want to create a macro that goes through each row in my sheet and checks columns F:I if they have values in them.
If ALL columns are empty then the current row should be deleted.
I tried recycling some code but when I run it, all rows in that sheet get deleted for some reason.
This is the code I have so far:
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim noValues As Range, MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
On Error Resume Next
Set noValues = Intersect(ActiveCell.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
End If
Next RowToTest
End Sub
You can do this way (it is more efficient to delete rows all in one go using Union):
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1") '<== Change to your sheet name
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)) '<== Column C cells to loop over from row 2 to last row
If Application.WorksheetFunction.CountBlank(rng.Offset(, 3).Resize(1, 4)) = 4 Then 'rng.Offset(, 3).Resize(1, 4)) limits to column F:I. CountBlank function will return number of blanks. If 4 then all F:I columns in that row are blank
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng) 'gather qualifying ranges into union range object
Else
Set unionRng = rng
End If
End If
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete '<== Delete union range object if contains items
Application.ScreenUpdating = True
End Sub
Or this way:
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)).Offset(, 3).Resize(.Cells(.Rows.Count, "C").End(xlUp).Row - 1, 4).Rows
On Error GoTo NextLine
If rng.SpecialCells(xlCellTypeBlanks).Count = 4 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng)
Else
Set unionRng = rng
End If
End If
NextLine:
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Try using WorksheetFunction.CountA.
Option Explicit
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
If WorksheetFunction.CountA(MyRange) = 0 Then
MyRange.EntireRow.Delete
End If
Next RowToTest
End Sub
Try the following:
On Error Resume Next
Set noValues = Intersect(myRange.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
Else
Set noValues = Nothing
End If
I'm more than new at this, and I'm having trouble sorting out For...Next loops.
I want to track to two text variables in two columns, so that when both variables are found in a row text is added to that row in a different column.
This is what I have so far:
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("B1:B100")
Set Rng2 = Range("A1:A100")
For Each cel In Rng1
If InStr(1, cel.Value, "A") > 0 Then
For Each cel In Rng2
If InStr(1, cel.Value, "B") > 0 Then
cel.Offset(0, 5).Value = "AB"
End If
Next
End If
Next cel
End Sub
You might even be able to just do this?
Sub AB()
With ActiveSheet
For I = 1 To 100
If InStr(1, .Cells(I, 2), "A") > 0 And InStr(1, .Cells(I, 1), "B") > 0 Then
.Cells(I, 6).Value = "AB" 'i think offset 5 is column F?
End If
Next
End With
End Sub
Appreciate you have an answer now, but here's a different method using Find. Always good to know several ways to do something.
Sub AB()
Dim rng As Range
Dim itemaddress As String
With Columns(1)
Set rng = .Find("A", searchorder:=xlByRows, lookat:=xlWhole)
If Not rng Is Nothing Then
itemaddress = rng.Address
Do
If rng.Offset(0, 1) = "B" Then
rng.Offset(0, 2).Value = "AB"
End If
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And itemaddress <> rng.Address
End If
End With
End Sub
You're using `cel' to step through each loop - the inner loop will get confused.
Along the vein of #findwindow answer (appeared as I was typing this). Loop just once and when a match is found check the cell next to it.
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Dim cel1 As Range
'Be specific about which sheet your ranges are on.
With ThisWorkbook.Worksheets("Sheet1")
Set Rng1 = .Range("B1:B100")
Set Rng2 = .Range("A1:A100")
End With
For Each cel1 In Rng1
'Check each value in column B.
If InStr(1, cel1.Value, "A") > 0 Then
'If a match is found, check the value next to it.
If InStr(1, cel1.Offset(, -1), "B") > 0 Then
cel1.Offset(, 4).Value = "AB"
End If
End If
Next cel1
End Sub
This is what I have already, and it works great in removing #N/As from the range. I am now looking to modify it to do the same thing for cells that contain 0.
Sub DeleteErrorRows()
Dim r As Range
Set r = Range("B:B").SpecialCells(xlCellTypeConstants, 16).EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub
Thanks :)
Try this. It autofilters your column and keeps rows that have the findMe value in your source worksheet. You can set it to 0 as I have in the example or to whatever else you want. It copies those rows (except for the header row) to the target sheet and then deletes them from the source sheet.
Note that this also finds the first empty row on the target sheet so that you can run it multiple times without overwriting what you've already moved to the target sheet.
Sub CopyThenDeleteRowsWithMatch()
Dim wb As Workbook
Dim ws As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim firstPasteRow As Long
Dim findMe As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
firstPasteRow = tgt.Range("B" & tgt.Rows.Count).End(xlUp).Row + 1
findMe = "0"
Set rng = ws.Range("B1:B" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="=" & findMe
With .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
.Copy tgt.Range("A" & firstPasteRow)
.Delete
End With
End With
' turn off the filters
ActiveSheet.AutoFilterMode = False
End Sub
Consider:
Sub DeleteZeroRows()
Dim r As Range, rTemp As Range, rB As Range
Set rB = Intersect(Range("B:B"), ActiveSheet.UsedRange)
Set r = Nothing
For Each rTemp In rB
If Not IsEmpty(rTemp) And rTemp.Value = 0 Then
If r Is Nothing Then
Set r = rTemp
Else
Set r = Union(r, rTemp)
End If
End If
Next rTemp
Set r = r.EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub