Having issues in VBA
Trying to delete all rows until value in row 1 = "**GRAD*"
I get Runtime Error 438
Code Below
Public Sub Delete()
Dim i As Long
i = 1 'Start from row 1
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
Do Until .Range("A" & i).Value = "**GRAD"
If .Rage("A" & i).Value <> "**GRAD" Then
.Rows(i).EntireRow.Delete
Else: i = i + 1 'Only increment if the row hasn't been deleted to prevent skipping rows
End If
Loop
End With
Application.ScreenUpdating = True
End Sub
Some help would be appreciated, new to VBA.
L.Dutch already gave you the answer to your question
here's an alternative and faster approach
to delete all rows until value in column 1 = "**GRAD*"
Option Explicit
Public Sub Delete()
Dim lastRowToDelete As Long
Dim f As Range
With ThisWorkbook.Worksheets("Sheet0001") '<-- reference your worksheet
With Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<-- reference its columns "A" cells from row 1 sown to last not empty one
Set f = .Find(what:="**GRAD", LookIn:=xlValues, lookat:=xlWhole, after:=.Range("A" & .Rows.Count)) '<-- look for the first cell whose value is "**GRAD"
If f Is Nothing Then '<-- if not found then...
lastRowToDelete = .Rows(.Rows.Count).Row '<-- the last row to delete is the last row of the range
Else '<-- otherwise...
lastRowToDelete = f.Row - 1 '<-- the last row to delete is the one preceeding the one with the found cell
End If
End With
If lastRowToDelete > 0 Then .Range("A1:A" & lastRowToDelete).EntireRow.Delete 'delete all rows in a single shot
End With
End Sub
Typo? I read If .Rage("A" & i).Value <> "**GRAD" Then while it should be If .Range("A" & i).Value <> "**GRAD" Then
Related
I have working code that checks for a criteria in each row, and if met, copies that whole row of data over to a different workbook. But! I need to be able to add text to the last column of the copied data (Column S) that essentially labels what criteria was met that made the code copy it over because I will soon be expanding to check for multiple different criteria.
So for every row that meets the criteria and gets copied, I want to add "Criteria1" next to it in column S in the new workbook (it will always be column S that will be the first available column).
I have mangled this code together through inheritance and all of your help, so I don't really even know where to begin.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim CoderBook As Workbook
Dim Referrals As Worksheet
Dim Review As Workbook
Dim Crit As Worksheet
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long
Set CoderBook = Workbooks.Open("Coder Referrals.xlsx")
Set Referrals = CoderBook.Sheets("Sheet1")
Set Review = ThisWorkbook
Set Crit = Review.Sheets("Criteria")
'Search code
LastRow = Crit.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
'Loop search code
For i = 2 To LastRow
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Or _
Crit.Range("I" & i) <> Crit.Range("J" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Crit.Rows(i).Value
End If
Next i
'End loop code
CoderBook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub
Split the or into two statements:
For i = 2 To LastRow
j = Referrals.Cells(Rows.Count, 1).End(xlUp).row + 1
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
Referrals.Range("S" & j).Value = "Criteria1"
End If
If Crit.Range("I" & i) <> Crit.Range("J" & i) Then
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
if Referrals.Range("S" & j).value = vbNullString then
Referrals.Range("S" & j).Value = "Criteria2"
Else
Referrals.Range("S" & j).Value = Referrals.Range("S" & j).Value & ", " & "Criteria2"
End if
Next i
I have excel with 5 different sheets.
sheet3 and sheet4 i want delete rows based on the single column cell value.
in sheet 3 i want to delete rows based on H column cell values if H2="#N/A" and H503="#N/A" then delete entire rows.
in sheet 4 i want to delete rows based on b column cell values if B2="320857876",B3="32085678",B4="12133435" the delete the entire rows where B column cell values starts with 302.
and i want to delete all Data from 'C' column
My excel sheet is like this
Using excel file
Sub Create()
Dim LastRow As Long
Dim i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i) = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
You've got a few requirements there and your code is fairly light but regarding the #N/A part of it, you can't just test for that text using the value approach, which is the default property returned for a range object.
Sub Create()
Dim LastRow As Long, i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i).Text = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
... you need to use .Text to get that to work, or, If IsError(Range("B" & i)) Then is another approach.
The rest of your requirements is just logic. The rest of your code is relatively sound so you just need to work through it.
I hope that helps.
Sub delete_rows()
Dim sheet As Worksheet, cell As Range
Count = 1
For Each sheet In ThisWorkbook.Worksheets
If Count = 3 Then
lastrow = sheet.Cells(sheet.Rows.Count, "H").End(xlUp).Row
Set Rng = sheet.Range("H1:H" & lastrow)
For i = Rng.Cells.Count To 1 Step -1
If Application.WorksheetFunction.IsNA(Rng(i).Value) Then
Rng(i).EntireRow.Delete
ElseIf Rng(i).Value = "#NA" Then
Rng(i).EntireRow.Delete
End If
Next
ElseIf Count = 4 Then
lastrow = sheet.Cells(sheet.Rows.Count, "B").End(xlUp).Row
Set Rng = sheet.Range("B1:B" & lastrow)
Debug.Print (Rng(4).Text)
If Rng(2).Value = "320857876" And Rng(3).Value = "32085678" And Rng(4).Value = "12133435" Then
For i = Rng.Cells.Count To 1 Step -1
If Left(Rng(i).Value, 3) = "302" Then
Rng(i).EntireRow.Delete
End If
Next
End If
lastrow = sheet.Cells(sheet.Rows.Count, "C").End(xlUp).Row
Set Rng = sheet.Range("C1:C" & lastrow)
For Each cell In Rng
cell.Value = ""
Next cell
End If
Count = Count + 1
Next
End Sub
I created a macro to in order to generate a daily report. The portion of the macro that finds a value in column AN and deletes the entire row (code edited to delete rows starting from the last used row), works well.
The following example deletes all the rows that do not contain the value "CAT","BAT", or "DOG in column AN.
'False screen updating
Application.ScreenUpdating = False
'deleting all other types other than CAT from "samples" tab (excluding the header row, row 1)
Sheets("sample").Select
Lastrow = Cells(Rows.Count, "AN").End(xlUp).Row
'Deleting rows from bottom up
For i = Lastrow To 2 Step -1
If Range("AN" & i).Value <> "CAT" And _
Range("AN" & i).Value <> "BAT" And _
Range("AN" & i).Value <> "DOG" Then
Rows(i).EntireRow.Delete
End If
Next i
However, would like to create another Sub that deletes all the rows that do contain a specific set of values.
I tried replacing <> with = and ==, however neither worked and no rows were deleted
Below is a sample how to delete rows based on a criteria in column A. Keep in mind that if we delete rows we go backwards to avoid index errors.
Try:
Option Explicit
Sub test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Where you delete you go backwards
For i = Lastrow To 2 Step -1
If .Range("A" & i).Value = "CAT" Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
Thank you everyone for help resolving this issue. I have found that the root cause of my problem was simply the condition statement at the end of my If/Then line. The "And_" statement was saying "If cell equals CAT and BAT and DOG, then delete row" NOT "If cell equals CAT or BAT or DOG, then delete row". Replacing "And_" with "Or_" has fixed this issue.
'False screen updating
Application.ScreenUpdating = False
'deleting all other types other than CAT from "samples" tab (excluding the header row, row 1)
Sheets("sample").Select
Lastrow = Cells(Rows.Count, "AN").End(xlUp).Row
'Deleting rows from bottom up
For i = Lastrow To 2 Step -1
If Range("AN" & i).Value = "CAT" Or _
Range("AN" & i).Value = "BAT" Or _
Range("AN" & i).Value = "DOG" Or _
Range("AN" & i).Value = "" Then
Rows(i).EntireRow.Delete
End If
Next i
However, I would also like to delete rows if the cells is Blank "". Why would the Sub ignore this line?
Range("AN" & i).Value = "" Then
Thanks!
A site that might be able to help you be the following.
https://www.excelcampus.com/vba/delete-rows-cell-values/
I adjusted the code a little.
Sub Delete_Rows_Based_On_Value()
'Apply a filter to a Range and delete visible rows
'Source: https://www.excelcampus.com/vba/delete-rows-cell-values
Dim ws As Worksheet
'Set reference to the sheet in the workbook.
Set ws = ThisWorkbook.Worksheets("sampel")
ws.Activate 'not required but allows user to view sheet if warning message appears
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'1. Apply Filter
ws.Range("AN3:BG1000").AutoFilter Field:=1, Criteria1:="<>CAT"
'2. Delete Rows
Application.DisplayAlerts = False
ws.Range("B1:G1000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
'3. Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
End Sub
I would tend to do it this way:
Sub DeleteRows()
Dim i As Integer
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("sample")
i=1
While sht.(i,1) <> "" 'Assuming first column is full of data to the bottom
If sht.Range("AN" & i) = "CAT" Then
sht.Rows(i).EntireRow.Delete
Else
i=i+1
End If
Wend
End Sub
I am trying to build a loop which would go through each cell in a row and each row in a range, check if the value in each cell is "apple" and it it is, copy the date the cell was checked for and save the date in a separate sheet next to the id for which the check was done. I would appreciate help on this. Thank you. enter image description here
Sheet1
Sheet2
Sub test()
Dim usedrows, usedcolumn, i, j As Integer
usedrows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
usedcolumn = ActiveSheet.Range("AZZ1").End(xlToLeft).Row
For j = 4 To usedcolumn 'loop through columns
For i = 4 To usedrows 'loop through rows
If Cells(i, usedcolumn) = "Apple" Then
Range("A" & i).Copy 'Copy the ID
'paste it
Cells(3, j).Copy ' Copy the date
'paste it
End If
If Range("A" & i) = "" Then 'if end of the row loop next column
Exit For
End If
Next
Next
End Sub
(pic link below for this example): The data starts on row "A11", one block of data is A11 to A14, I need to search that range to see if it contains a member name from a list on sheet 2, for example Erik Christensen, if the list on sheet 2 doesnt have that name I need to delete rows A11 thru A14 and continue to the next block. The list on sheet 2 will have a varying amount of members to check so that needs to be taken into consideration. Once all the rows have been processed, I need to sorth them back to start at row A11.Please see pic and I will be extremely thankful for any help.
Sheet 1
For the below answer, I have made a few assumptions:
Your data will always start on row 11 of the first sheet in the
workbook.
The search term will always be found in the second row, below
Object:...
The data will always present in rows of 4, as shown in the picture,
with End: in the 4th row.
The list of valid names is in column A (beginning on A1) of the
second sheet in the workbook.
By "sorted back to start on row A11", I assume you mean that the
remaining blocks of data should start on row A11 and continue to the
end of the data, not that any actual sorting (i.e. by name) is
required.
This code will loop through all blocks of data (beginning with the last one, since we are deleting rows). If any of the names in column A of the second sheet appear in the block of data, that block is skipped. Otherwise, if no names appear, that block is deleted.
Sub SearchAndDeleteList()
Dim i As Long
Dim j As Long
Dim LRow As Long
Dim LListRow As Long
Dim BMatch As Boolean
'Find last instance of "End:" in
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row
'Find last non-blank row in column A of second sheet
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
If LRow >= 11 Then
'Make sure there are at least 11 rows of data
i = LRow
'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line
Do
BMatch = False
For j = 1 To LListRow
'Test this block to see if the value from j appears in the second row of data
If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then
BMatch = True
Exit For
End If
Next j
'Application.StatusBar = "Match status for row " & i & ": " & BMatch
If Not BMatch Then
'Loop backwards to find the starting row (no lower than 11)
For j = i To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For
Next j
Sheets(1).Rows(j & ":" & i).Delete
i = j - 1
Else
'Find next block
If i > 11 Then
For j = i - 1 To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For
Next j
i = j
Else
i = 10 'Force the loop to exit
End If
End If
'Application.StatusBar = "Moving to row " & i
Loop Until i < 11
'Loop back through and delete any blank rows
LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
'MsgBox "Second checkpoint: new last row of data is " & LRow
For i = LRow To 11 Step -1
If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete
Next i
End If
'Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
thanks to Nick's cracking actual OP's needs, I hereby propose a solution that should be more maintainable and/or changeable as per Op's future needs
Option Explicit
Sub SearchAndDeleteList2()
Dim dataSht As Worksheet
Dim dataRng As Range, namesRng As Range, cell As Range, rangeToDelete As Range
Dim firstAddress As String
'------------------------------
' setting stuff - begin
Set dataSht = ThisWorkbook.Sheets("Sheet1Data") '<== change 'data' sheet as per your needs
With dataSht
Set dataRng = .Range("A11:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
If dataRng.Rows(1).row < 11 Then Exit Sub
With ThisWorkbook.Sheets("Sheet2Names") '<== change 'names' sheet as per your needs
Set namesRng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
Call ApplicationSet(False, False, xlCalculationManual, False)
' setting stuff - end
'------------------------------
'------------------------------
' core code - begin
Set cell = dataRng.Find("End:", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not MyMatch(GetName(cell.Offset(-2)), namesRng) Then Call UpdateRngToDelete(rangeToDelete, dataSht.Rows(cell.row).Offset(-3).Resize(4))
Set cell = dataRng.FindNext(cell)
Loop While cell.Address <> firstAddress
rangeToDelete.Delete
End If
' core code - end
'------------------------------
Call ApplicationSet(True, True, xlCalculationAutomatic, True)
End Sub
Function GetName(cell As Range) As String
Dim iIni As Integer
Dim iEnd As Integer
iIni = InStr(cell.value, """") '<== the 'name' is always preceeded by '"' character
iEnd = InStr(cell.value, "\") '<== the 'name' is always follwed by '/' character
GetName = Mid(cell.value, iIni + 1, iEnd - iIni - 1)
End Function
Sub UpdateRngToDelete(baseRng As Range, toBeAddedRng As Range)
If baseRng Is Nothing Then
Set baseRng = toBeAddedRng
Else
Set baseRng = Union(baseRng, toBeAddedRng)
End If
End Sub
Function MyMatch(value As String, rng As Range) As Boolean
MyMatch = Not IsError(Application.Match(value, rng, 0))
End Function
using separate functions or subs makes it easier (and faster!) to keep control and debug future code changes