I'm working to identify rows in sheet 1 that are not blank in column A and don't have a Y or L in column V. Then I need to copy the contents of that row, then paste values to an open row on the next worksheet. Lastly, I need to clear contents on the original sheet for that row. I'm getting stuck when it comes time to paste. Error 1004 - Method 'Range' of object'_Worksheet' failed. I appreciate any help.
Option Explicit
Option Compare Text
Sub EndMove()
Dim rowCount As Long, i As Long
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Range("A11").Select
rowCount = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
Application.ScreenUpdating = False: Application.EnableEvents = False
Call ShowAllRecords
For i = 11 To rowCount
If ws.Range("V" & i) <> "y" And ws.Range("V" & i) <> "l" Then
If ws.Range("A" & i) <> "" Then
Dim rowCount2 As Long, j As Long
Dim sRng As Range
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(ActiveSheet.Index + 1)
Dim wAct As Worksheet
Dim lRow As Long
Dim End_Row As Long
Set wAct = ws
Set sRng = ws.Range("V" & i)
If Not IsDate("01 " & wAct.Name & " 2017") Or wAct.Name = "Dec" Then MsgBox "Not applicable for this sheet.": Exit Sub
If ActiveSheet.Index = ThisWorkbook.Worksheets.Count Then MsgBox "This is the last worksheet cannot move forward.": Exit Sub
wAct.unprotect
With ws2
.unprotect
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
End If
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).Copy
.Range("A" & End_Row).PasteSpecial xlPasteValuesAndNumberFormats
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).ClearContents
.Range("A1000").Value = End_Row
.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
End With
wAct.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
Application.CutCopyMode = False
End If
End If
Next i
Application.EnableEvents = True: Application.ScreenUpdating = True
Call FilterBlanks
MsgBox "Move Complete"
End If
End Sub
It seems there is no line in your code that would assign value to rowCount2. So when you check it in code below it gives always false and therefore skips this part
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
but that part is essential as it is the only part where End_Row is assigned value. So then when you try to do this .Range("A" & End_Row) there is nothing in End_Row. Set up a breakpoint on that line and check Locals screen for End_Row to make sure it is this.
I am currently in the process of creating a VBA Script where i extract a list of raw data and filter out values Apple, Banana, and Oranges. I then delete all the other rows if it is not the values mentioned above.
So for example i have apple, banana, orange, grape, mandarin, avocado, coconut, lemon, watermelon.
I only want to keep apple, banana and orange in the end. If it has any of the other fruits i want that whole row of information removed.
Sub RMWO_Clean()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("Q" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("Q1:Q" & lastRow)
Columns("AF:AF").Select
Selection.TextToColumns Destination:=Range("AA1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
With rng
.AutoFilter Field:=1,Criteria1:="<>*Apple*", Operator:=xlAnd, Criteria2:="<>*Banana*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
End Sub
I know that you cannot use
Criteria3:=xx
I have also tried
Criteria1:=Array("<>Apple", "<>Banana", "<>Orange")
But this seems to only leave orange behind.
Are you able to let me know what i am doing wrong?
Criteria1:=Array("<>Apple", "<>Banana", "<>Orange") needs Operator:=xlFilterValues operator, and yet won't work with those "<>"
so you can fool it by thinking the other way around:
filter "good" records
delete all records that are not good
like follows:
With rng
.AutoFilter Field:=1, Criteria1:=Array("Apple", "Banana", "Orange"), Operator:=xlFilterValues
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) ' reference 'records' only (skip headers)
Select Case Application.Subtotal(103, .Cells) ' count number of filtered cells
Case 0 'if no cells to save
.EntireRow.Delete ' delete all rows
Case Is < .Count 'if there's at least one row to delete
Set saveRng = .SpecialCells(xlCellTypeVisible) ' store cells to save
.Parent.AutoFilterMode = False 'remove filter
saveRng.EntireRow.Hidden = True 'hide cells to save
.SpecialCells(xlCellTypeVisible).EntireRow.Delete 'delete visible cells
saveRng.EntireRow.Hidden = False 'bring cells to save visible back
End Select
End With
.Parent.AutoFilterMode = False
End With
Starting with:
I run:
Dim myRange As Range
Set myRange = ActiveSheet.Range("$A$1:$A$4")
myRange.AutoFilter Field:=1, _
Criteria1:="<>*Banana*", Operator:=xlAnd, Criteria2:="<>*apple*"
...and I get:
...and then I run:
myRange.AutoFilter Field:=1
...and I get:
I can delete the non-filtered rows with:
Rows("2:7").Delete Shift:=xlUp
Putting it all together, you could do something like:
Sub DeleteRowsExceptApplesAndBananas()
Const startCell = "A1"
Dim rgFilter As Range
'get range to filter
With Sheets("Sheet1")
Set rgFilter = Range(.Range(startCell), .Range(startCell).End(xlDown))
'set filter
rgFilter.AutoFilter 1, "<>*Banana*", xlAnd, "<>*apple*"
'delete rows beginning one below startCell's row
Range(.Range(startCell).Offset(1).Row & ":" & _
.Range(startCell).End(xlDown).Row).Delete (xlUp)
'un-filter
rgFilter.AutoFilter 1
End With
End Sub
It doesn't seem to me that Range.AutoFilter will do what you want it to here, precisely because you can only use two criteria for it.
I'd personally prefer to solve this problem with a loop operation, like so:
Option Compare Text
Sub Macro1()
Dim ws As Worksheet
Dim rng As Range
Dim col As String
Dim i As Integer
Set ws = ActiveWorkbook.Sheets("Sheet1")
col = "A"
i = 1
Set rng = ws.Range(col & i)
Do
Select Case rng.FormulaR1C1
Case "apple", "orange", "banana"
i = i + 1
Case Else
rng.Delete xlShiftUp
End Select
Set rng = ws.Range(col & i)
Loop Until rng.FormulaR1C1 = ""
End Sub
The code above assumes that you've already done all the preprocessing you've needed to do to extract your list of fruits, and that that list begins in cell A1 of Sheet1, although you can of course modify that code to put the list anywhere you'd like.
Version 1 bellow uses a "reverse" AutoFilter
Version 2, moves all rows to keep to a new sheet, and deletes the old (very fast for a lot of rows)
.
Version 1
Option Explicit
Public Sub DeleteRowsForCriteria()
Const FILTER_COL = "Q"
Const To_KEP = "apple banana orange"
Dim ws As Worksheet, lr As Long
Set ws = Sheet1 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, FILTER_COL).End(xlUp).Row
Application.ScreenUpdating = False
ws.Range("AF1:AF" & lr).TextToColumns Destination:=ws.Range("AA1"), _
TextQualifier:=xlDoubleQuote, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
Dim filterCol As Range, toKep As Variant, keep As Range
Set filterCol = ws.Range("Q1:Q" & lr)
toKep = Split(To_KEP)
With filterCol 'Reverse Filter - show all rows to keep ("apple banana orange")
.AutoFilter Field:=1, Criteria1:=toKep, Operator:=xlFilterValues
If .SpecialCells(xlCellTypeVisible).Count > 1 Then
Set keep = .SpecialCells(xlCellTypeVisible).EntireRow
End If
.AutoFilter 'Unhide all rows
keep.Rows.Hidden = True 'Hide all rows to keep ("apple banana orange")
.SpecialCells(xlCellTypeVisible).EntireRow.Delete 'Delete unwanted (now visible)
End With
keep.Rows.Hidden = False 'Unhide rows to keep ("apple banana orange")
Application.ScreenUpdating = True
End Sub
.
Version 2
Public Sub DeleteRowsForCriteriaFast()
Const FILTER_COL = "Q"
Const To_KEP = "apple banana orange"
Dim ws1 As Worksheet, ws2 As Worksheet, lr As Long, wsName As String, keep As Range
Set ws1 = Sheet1 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws1.Cells(ws1.Rows.Count, FILTER_COL).End(xlUp).Row
Application.ScreenUpdating = False
ws1.Range("AF1:AF" & lr).TextToColumns Destination:=ws1.Range("AA1"), _
TextQualifier:=xlDoubleQuote, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
Dim filterCol As Range, toKep As Variant
Set filterCol = ws1.Range("Q1:Q" & lr)
toKep = Split(To_KEP)
Application.DisplayAlerts = False
Set ws2 = ThisWorkbook.Worksheets.Add(After:=ws1)
wsName = ws1.Name
With filterCol
.AutoFilter Field:=1, Criteria1:=toKep, Operator:=xlFilterValues
If .SpecialCells(xlCellTypeVisible).Count > 1 Then
.EntireRow.Copy
ws2.Cells.PasteSpecial xlPasteColumnWidths
ws2.Cells.PasteSpecial xlPasteAll 'Paste data on new sheet
ws1.Delete: ws2.Name = wsName: ws2.Cells(1).Select
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
End Sub
.
TextToColumns default parameters
DataType:=xlDelimited
ConsecutiveDelimiter:=False
Tab:=False
Semicolon:=False
Comma:=False
Space:=False
Other:=False
I'm trying to delete an entire row in excel if column B and C are blank for that row. I have this vba code that deletes an entire row if the whole row is blank. How can I only delete the row if B and C have no value?
Thank you
Sub DeleteBlank()
Dim rng
Dim Lastrow As Integer
Set rng = Nothing
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
For Each i In Range("B1:B" & Lastrow)
If Application.CountA(i.EntireRow) = 0 Then
If rng Is Nothing Then
Set rng = i
Else
Set rng = Union(rng, i)
End If
End If
Next i
MsgBox (Lastrow)
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
End Sub
--Update--
The problem is solved. Thanks to izzymo and sous2817
Here is the current code
Sub DeleteBlank()
Dim i As Integer
Dim Lastrow As Integer
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
MsgBox (Lastrow)
For i = Lastrow To 2 Step -1
If Trim(Range("B" & i).Value) = "" And Trim(Range("C" & i).Value) = "" Then
Range("B" & i).EntireRow.Select
Selection.Delete
End If
Next i
MsgBox "Done"
End Sub
As asked for, here is a way to do it without looping:
Sub NoLoopDelete()
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
With Sheet1.Range("A1:I" & lr)
.AutoFilter
.AutoFilter Field:=2, Criteria1:="="
.AutoFilter Field:=3, Criteria1:="="
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End Sub
The results should be the same, but this way should be faster, especially if you have a lot of rows. Obviously, change the column reference to suit your layout and feel free to fancy it up w/ some error checking,etc.
Try this
Sub DeleteBlank()
Dim i as Integer
Dim Lastrow As Integer
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If Trim(Range("B" & i).Value) = "" And Trim(Range("CB" & i).Value) = "" Then
Range("B" & i).EntireRow.Select
Selection.Delete
i = i - 1
End If
Next i
MsgBox "Done"
End Sub
I am getting following error when trying to auto filter in vba:
The object invoked has disconnected from its clients.
So what i am trying to do is auto filter, search for empty spaces and delete the rows. Can anyone please help?
I have tried the standard solutions provided online e.g. option explicit etc but to no avail.
Data:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngLastRow As Long
Dim lngLastRowD As Long
Application.ScreenUpdating = False
'Concatenate the Row A and B
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets(1).Range("D2:D" & lngLastRow).Value = Evaluate("=A2:A" & lngLastRow & "&""""&" & "B2:B" & lngLastRow)
lngLastRowD = Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
Set ws = Worksheets(1)
Set Rng = Worksheets(1).Range("A2:A" & lngLastRowD)
With Rng
.AutoFilter field:=1, Criteria1:=""
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
Application.ScreenUpdating = True
ThisWorkbook.Sheets(1).Range("A2").Select
End Sub
Since Worksheets() want the name of the sheet, like "Sheet1", use sheets(1).
Why are you creating the variable ws and rng when you only use them once
I ran this and it deleted rows with no data in column A.
Private Sub Worksheet_Change()
Dim lngLastRow As Long
Dim lngLastRowD As Long
Application.ScreenUpdating = False
'Concatenate the Row A and B
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
sheets(1).Range("D2:D" & lngLastRow).Value = Evaluate("=A2:A" & lngLastRow & "&""""&" & "B2:B" & lngLastRow)
lngLastRowD = Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
With sheets(1).Range("A2:A" & lngLastRowD)
.AutoFilter field:=1, Criteria1:=""
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
sheets(1).AutoFilterMode = False
Application.ScreenUpdating = True
Sheets(1).Range("A2").Select
End Sub
In the end i restored in approaching the issue from another angle:
Dim i As Integer, counter As Integer
i = 2
For counter = 1 To lngLastRowD
If Worksheets(1).Range("A2:A" & lngLastRowD).Cells(i) = "" And Worksheets(1).Range("D2:D" & lngLastRowD).Cells(i) <> "" Then
Worksheets(1).Range("A2:A" & lngLastRowD).Range("A" & i & ":D" & lngLastRowD).Select
Selection.Delete
GoTo TheEND
Else
i = i + 1
Debug.Print "i is " & i
End If
Next
I have a code to look for the word "it" in column B.Then if the code finds it, it copies the cell to the right of it to another worksheet. Would anyone know how to modify it so it reads the second "it" in column B, not the first? Thank you
Dim rcell As Range
Application.ScreenUpdating = False
For Each rcell In Range("B2:B" & ActiveSheet.UsedRange.Rows.count + 1)
If rcell.Value = "it" Then
rcell.Offset(, 1).Copy Sheets("another sheet").Range("C" & Rows.count).End(3)(2)
End If
Next rcell
Application.ScreenUpdating = True
End Sub
Try this:
Dim rcell As Range
Application.ScreenUpdating = False
For Each rcell In Range("B2:B" & ActiveSheet.UsedRange.Rows.count + 1)
Dim place%
'find first instance of "it"
place = InStr(1,rcell.Value, "it")
If place <> 0 Then
'if there is one, check to see if there is a second instance
'line below may have to use place+1 instead of just place
If InStr(place,rcell.Value, "it") <> 0 Then
rcell.Offset(, 1).Copy Sheets("another sheet").Range("C" & Rows.count).End(3)(2)
End If
End If
Next rcell
Application.ScreenUpdating = True
End Sub