I am using the code below to copy and paste the row to a new worksheet. When testing manually it seems to work but when running macro excel freezes. Basically if column L has the word Completed it shoud copy and paste that row to the Completed worksheet then return and delete the original row (everything with the work completed should be moved to completed folder)
Public Sub Completed()
Application.ScreenUpdating = False
Sheets("BPM-Other").Select
FinalRow = Range("L11579").End(xlUp).Row
For x = FinalRow To 2 Step -1
ThisValue = Range("L" & x).Value
If ThisValue = "Completed" Then
Range("A" & x & ":O" & x).Cut
Sheets("BPM_Other Completed").Select
nextrow = Range("L10500").End(xlUp).Row + 1
Range("A" & nextrow).Select
ActiveSheet.Paste
Sheets("BPM-Other").Select
Range("A" & x & ":L" & x).Delete Shift:=xlUp
End If
Next x
Application.ScreenUpdating = True
End Sub
I used, excel filter and copy, filter and delete option to accomplish the work. Please have a look at the below code.
Logic I used here is- Filter 12th column with value 'Completed'-> Insert the filtered rows into target sheet, starting after last used row -> Delete all the Completed rows in source sheet -> Remove the filter in source sheet
Sub filter()
'specify sheet name
src = "BPM-Other"
tar = "BPM_Other Completed"
'calculating last used rows in both source and target sheet
src_last = Sheets(src).Cells(Rows.Count, "A").End(xlUp).Row
tar_last = Sheets(tar).Cells(Rows.Count, "A").End(xlUp).Row
With Sheets(src)
.AutoFilterMode = False
'assuming O is your last column, change as needed
With .Range("A1:O" & src_last)
'L is 12th column
.AutoFilter Field:=12, Criteria1:="Completed"
'Offset used to ignore the header
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(tar).Range("A" & tar_last + 1)
'delete the rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End With
'to remove the filter in source sheet
On Error Resume Next
Sheets(src).ShowAllData
On Error GoTo 0
End Sub
Related
I have written a short macro to delete all rows that have a value of "Not Applicable" in column I, for the "Budget" tab of my workbook.
The macro does not seem to be doing anything when I run it through my testing:
Sub Remove_NA_Macro_Round_2()
With Sheets("Budget") 'Applying this macro to the "Budget" sheet/tab.
'Establishing our macro range parameters
Dim LastRow As Long
Dim i As Long
'Setting the last row as the ending range for this macro
LastRow = .Range("I50").End(xlUp).Row
'Looping throughout all rows until the "LastRow" ending range set above
For i = LastRow To 1 Step -1
If .Range("I" & i).Value = "Not Applicable" Then
.Range("I" & i).EntireRow.Delete
End If
Next
End With
End Sub
I appreciate any help!
Alternatively, when deleting rows based on a condition, it is faster to use a filter then looping.
Dim rng As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:I" & Cells(Rows.Count, "I").End(xlUp).Row)
Application.DisplayAlerts = False
With rng
.AutoFilter
.AutoFilter field:=9, Criteria1:="Not Applicable"
rng.Resize(rng.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Delete 'deletes the visible rows below the first row
.AutoFilter
End With
Application.DisplayAlerts = True
You are not actually referencing the With Sheets("Budget"). Add a period . before each instance of Range, otherwise there's an implicit ActiveSheet, which is not necessarily the Budget tab.
With Sheets("Budget")
...
LastRow = .Range("I50").End(xlUp).Row
...
If .Range("I" & i).Value = "Not Applicable" Then
.Range("I" & i).EntireRow.Delete
End If
...
End With
EDIT:
Based on commentary and your provided screenshot, change how LastRow is determined (get rid of the hard-coded I50):
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
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 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 transfer a row of data from one table to a new row at the bottom of another table when a date is entered into the cell(Column "AD").
When I try, data is transferred to the row under the last row of the table.
Sub TRANSFER_DATA()
For Each Cell In Worksheets("Sheet1").Range("AD2:AD1000")
If Cell.Value > 0 Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Cut
Sheets("Sheet2").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next Cell
End Sub
If i understood your question you can try this code:
Execute the macro when you have the sheet1 active
Sub TRANSFER_DATA()
Dim lastrow, i As Long
Dim ADCell as Integer
ADCell=30 ' control the column AD
'control how many data there are in column A. If you want count how many rows
'with ColumnAD change 1 in 30 (lastrow = Cells(rows.count,30).End(xlUp).Row)
lastrow = Cells(rows.count, 1).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, ADCell) > 0 Then
rows(i & ":" & i).Select
Selection.Cut Worksheets("Sheet2").Range("A" & rows.count).End(xlUp).Offset(1)
End If
Next i
End Sub
I tried the code and works.
UPDATED THE POST AFTER YOUR COMMENT
Sub TRANSFER_DATA()
Dim lastrow, i, ls As Long
Dim ADCell as Integer
ADCell=30 ' control the column AD
'control how many data there are in column A. If you want count how many rows
'with ColumnAD change 1 in 30 (lastrow = Cells(rows.count,30).End(xlUp).Row)
lastrow = Cells(rows.count, 1).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, ADCell) > 0 Then
rows(i & ":" & i).Select
Selection.Cut Worksheets("Sheet2").Range("A" & rows.count).End(xlUp).Offset(1)
End If
Next i
With Sheets("sheet2")
ls = .Cells(.rows.count, ADCell).End(xlUp).Row
.ListObjects("TableName").Resize Range("$A$1:$AD$" & ls)
End With
End Sub
the updated code have another variable, ls. This variable has the number of not empty rows of sheet2. ListObjects.("name of your table") insert the new data (rows) into the table.
I hope this helps
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