I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell
Related
Real project sample here: http://s000.tinyupload.com/?file_id=06911274635715855845
Sample here
its all in the title,
Lets say i got a doc with ten columns and three hundred rows, A and B contain a number and C to J can contain many words and sometimes the word "Banana".
I'd like to automate a task that goes line by line on the worksheet and deletes the whole row if every cell between C and J contains "Banana", ignoring A and B.
Usually when i have such a question i submit my ideas but i'm quite stumped here from the get go.
Would you be kind enough to help?
Try the next code, please. It will delete all rows having the same string in columns C to J ("Banana" inclusive...). It would be very fast. The deletion is done at the end, at once:
Edited:
Since, in an worksheet containing tables, the non contiguous entire rows range deletion is not allowed, I adapted the code to test if such a table is involved, intersect the collected range to be deleted (its EntireRow) with the table and delete the intersected table rows.
Please, test next updated code:
Sub testDeleteRowsSameWord()
Dim sh As Worksheet, lastRow As Long, i As Long, rngDel As Range
Set sh = ActiveSheet ' use here your necessary sheet
lastRow = sh.Range("C" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
If WorksheetFunction.CountIf(sh.Range("D" & i & ":EA" & i), _
sh.Range("D" & i).Value) = 128 Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End If
Next i
If Not rngDel Is Nothing Then
If sh.ListObjects.Count > 0 Then
If sh.ListObjects.Count > 1 Then MsgBox _
"This solution works only for a table...": Exit Sub
Dim Tbl As ListObject, rngInt As Range
Set Tbl = sh.ListObjects(1)
Set rngInt = Intersect(Tbl.Range, rngDel.EntireRow)
If rngInt.Count > 0 Then
rngInt.Delete xlUp
Else
rngDel.EntireRow.Delete xlUp
End If
Else
rngDel.EntireRow.Delete xlUp
End If
End If
End Sub
They are infinite ways to achieve what you want.
One for example can be something like :
Dim i As Integer, j As Integer
Dim mBanana As Boolean
For i = 299 To 0 Step -1 'rows 1 to 300
mBanana = True
For j = 0 To 7 'columns C to J
If Sheets("nameofyoursheet").Range("C1").Offset(i, j).Value <> "Banana" Then
mBanana = False
End If
Next j
If mBanana = True Then
Sheets("nameofyoursheet").Range("C1").Offset(i, j).EntireRow.Delete
End If
Next i
Note that the numbers of rows and columns are hardcoded in the parameters of the For, you can easily adapt the code.
How do I get the position of the last non-empty cell in a filtered column without dropping the applied Autofilter? I understand it's easy to get the number of the last visible row with
Dim ws as Worksheet, rng As Range
Set rng = Range(Letter & 1 & ":" & Letter & 1) ' where Letter is the letter code of the column
GetLastVisibleRow = ws.Range(Split(ws.Cells(, rng.Column).Address, "$")(1) & ws.Rows.count).End(xlUp).row
but I need the number of the last filled row instead. At the same time, I'd like to avoid setting
ws.AutoFilterMode = False
if it's possible.
Thanks in advance.
Probably not the most efficient or fastest method, but this appears to work:
Function GetLastCellOfColumn(ColLetter As String) As Range
Dim Col As Range
Dim Rw As Long
Set Col = Range(ColLetter & ":" & ColLetter)
Set GetLastCellOfColumn = Intersect(ActiveSheet.UsedRange, Col)
For Rw = GetLastCellOfColumn.Cells.Count To 1 Step -1
If Len(GetLastCellOfColumn.Cells(Rw).Value) > 0 Then
Set GetLastCellOfColumn = GetLastCellOfColumn.Cells(Rw)
Exit Function
End If
Next
End Function
A charming solution by #jkpieterse plus a useful comment by #BigBen is exactly what I was looking for. Just to finalize the thread, the function returning the row number is
Function GetLastFilledCellOfColumn(ws As Worksheet, ColLetter As String) As Long
Dim Col As Range, Urng As Range, Rw As Long
Set Col = ws.Range(ColLetter & ":" & ColLetter)
Set Urng = Intersect(ws.UsedRange, Col)
For Rw = Urng.Cells.count To 1 Step -1
If Not IsEmpty(Urng.Cells(Rw)) Then
GetLastFilledCellOfColumn = Rw
Exit Function
End If
Next
End Function
Problem solved.
So maybe this is an alternative way to look into:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("_FilterDatabase").Columns(col)
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I'm afraid I rushed this a little and might have made a mistake but will have to get going. Hopefully you understand whats going on =)
Edit:
The above would definately work, but as figured out through the chat, there is actually a ListObject involved, called Table1, which throws of the AutoFilter range. So here are two alternative ways of doing the same thing:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("Table1")
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
Or, when you don't know the name of the table:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .ListObjects(1).Range
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I have 2 columns A and B
I want to copy the Column A data into Column B. There are few blank cells in A, but those blanks should not overwrite any data in column B. Only the cells which have data should be copied into B.
How can this be achieved in VBA?
This is probably not a complete solution, but might give you some ideas:
Sub test()
Dim R As Range
Set R = Range("A:A").SpecialCells(xlCellTypeConstants, 23)
R.Offset(0, 1).Value = R.Value
End Sub
If the data in column A include computed values, this might not work as intended.
Since you have a conditional paste, you will need to loop here. Check each value in Column A and move the VALUE to Column B (if-and-only-if Column A is not blank)
Sub Jeeped()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If ws.Range("A" & i) <> "" Then
ws.Range("B" & i).Value = ws.Range("A" & i).Value
End If
Next i
End Sub
I want to filter column B based on values like "Unknown", then filter L column to have un-null values. copy the L column.
Paste values only to the column B.
Before:
ColumnB ..... Column L
1 ..... a
2 ..... b
Unknown.c
3.......d
Unknown.e
Unknown.
After
1 ..... a
2 ..... b
c.......c
3.......d
e.......e
Unknown..
Set r1 = Range("B:B").SpecialCells(xlCellTypeVisible)
Set r2 = Range("L:L").SpecialCells(xlCellTypeVisible)
Set myMultipleRange = Union(r1, r2)
Application.ScreenUpdating = False
sh1.Range("B:L").AutoFilter
sh1.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues
sh1.Range("L:L").AutoFilter Field:=11, Operator:=xlFilterValues, Criteria1:="<>"
LstRw = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If LstRw <> 0 Then
myMultipleRange.FillLeft
End If
The above code will copy and paste including the format.
Copy/paste in a filtered table is no good idea, because it inserts data continously even in hidden rows and messes up your data.
I recommend the following:
Filter data
Loop through all visible cells and copy the data row by row
If the following data is given …
… and you want to replace unkown with the data in column L, you can do the following:
Option Explicit
Public Sub FilterAndCopy()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Tabelle1")
'Filter data
ws.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DestinationRange As Range
On Error Resume Next 'next line throws error if filter returns no data rows
Set DestinationRange = ws.Range("B2", "B" & LastRow).SpecialCells(xlCellTypeVisible) 'find visible cells between B2 (exclude header) and last row in B
On Error GoTo 0 'always re-activate error reporting!
If Not DestinationRange Is Nothing Then 'do it only if there is visible data
Dim Cell As Range
For Each Cell In DestinationRange 'copy each value row wise
Cell.Value = Cell.Offset(ColumnOffset:=10).Value 'column L is 10 columns right of B
Next Cell
End If
End Sub
Alternative solution - simply go through each cell in column B and replace "Unknown" with a respective value in column L.
Sub foo()
Dim lngLastRow As Long
Dim rngCell As Range
With Sheet1
LastRow = .Range("B" & Rows.Count).End(xlUp).Row
For Each rngCell In .Range("B1:B" & LastRow)
If rngCell.Value = "Unknown" Then
rngCell.Value = .Range("L" & rngCell.Row).Value
End If
Next rngCell
End With
End Sub
P.S. Make sure to replace With Sheet1 statement with a relevant sheet name/code.
I have a named range for an entire column named DAY.
I have a macro that sets pagebreaks every time a cell's value in the DAY column changes (when changing from day 1, to day 2, or day 3, there will be a page break for printing).
The macro specifies the column by letter, like "A" or "B" or "C" or "H".
How can I specify the "DAY" named range so if it moves, the code doesn't break?
Attention to:
For Each c In Range("C1:C" & lastrow)
I want to change Range("C1:C"to Range("DAY".
This breaks in various syntax forms I tried.
Sub Set_PageBreaks_DAY()
Dim lastrow As Long, c As Range
Dim i As Integer, rngData As Range
Set rngData = Range("A1").CurrentRegion
i = Application.WorksheetFunction.Match("DAY", Range("A1:AZ1"), 0)
lastrow = Cells(Rows.Count, i).End(xlUp).Row
Application.ScreenUpdating = False
ActiveSheet.ResetAllPageBreaks
For Each c In Range("C1:C" & lastrow)
If c.Offset(1, 0).Value <> c.Value And c.Offset(1, 0) <> "" Then
c.Offset(1, 0).PageBreak = xlPageBreakManual
End If
Next c
Application.ScreenUpdating = True
End Sub
First, it is important to note that Named ranges have 2 possible scopes which will affect how to access it. If your named range has workbook scope, then you should use
Dim Named_range_day as Range
Set Named_range_day = ThisWorkbook.Names("Day").RefersToRange
If the named range has worksheet scope, then use
Dim Named_range_day as Range
Set Named_range_day = wksht.Names("Day").RefersToRange
where wksht is the worksheet variable for the worksheet containing the named range.
The reason JLILI Aman's answer didn't work is you have to convert the column index number to a column letter first using
columnLetter = Split(Columns(i).Address(), "$")(2)
So for example
Sub Set_PageBreaks_CREW()
Dim lastrow As Long, c As Range
Dim i As Integer, rngData As Range
Set rngData = Range("A1").CurrentRegion
i = Application.WorksheetFunction.Match("DAY", Range("A1:AZ1"), 0)
lastrow = Cells(Rows.Count, i).End(xlUp).Row
Application.ScreenUpdating = False
ActiveSheet.ResetAllPageBreaks
columnLetter = Split(Columns(i).Address(), "$")(2)
Var = columnLetter & "1:" & columnLetter
For Each c In Range(Var & lastrow)
If c.Offset(1, 0).Value <> c.Value And c.Offset(1, 0) <> "" Then
c.Offset(1, 0).PageBreak = xlPageBreakManual
End If
Next c
Application.ScreenUpdating = True
End Sub
Range("DAY").Resize(lastrow,1)
The above will reference the cell with name DAY and lastrow rows below it and in one column.
In general to reference a table of 100 rows and 5 columns with the top left at a cell, for example G2 use
Range("G2").Resize(100,5)
the above is entirely equivalent to
Range("G2:K101")
buy you don't have to do any of the weird string math with Range("G2:K" & count+1) etc.