I am trying to delete all row where column A value(Its formatted as date) is less than today's date. I have to run these through entire non empty A column. but facing an issue with the code to run as loop through entire rows. each time its deleting only 1 row. Please let me know how to run it through entire row set.
Sub DeleteRowBasedOnDateRange()
Dim spem As Workbook
Dim ws As Worksheet
Dim N As Long, I As Long
Set spem = Excel.Workbooks("SwitchP.xlsm")
Set ws = spem.Worksheets("data")
N = ws.Cells(Rows.count, "A").End(xlUp).row
For I = 2 To N
If Cells(I, "A").Value < Date Then
Cells(I, "A").EntireRow.Delete
I = I + 1
End If
Next I
End Sub
Quick fix
Loop backwards.
Also you do not need the I=I+1 as that is done automatically.
Sub DeleteRowBasedOnDateRange()
Dim spem As Workbook
Dim ws As Worksheet
Dim N As Long, I As Long
Set spem = Excel.Workbooks("SwitchP.xlsm")
Set ws = spem.Worksheets("data")
N = ws.Cells(ws.Rows.count, "A").End(xlUp).row
For I = N to 2 Step -1
If ws.Cells(I, "A").Value < Date Then
ws.Rows(I).Delete
End If
Next I
End Sub
Related
I need to copy a row from a sheet into a third sheet, if the ServerID exists in both sheets
Sub XDDXH()
Dim i As Integer
Dim z As Integer
Dim j As Integer
For i = 2 To 3318
For z = 8 To 731
If Worksheets("Sheet1").Range(i, 1).Value = Worksheets("Sheet2").Range(z, 8).Value Then
Worksheets("Sheet1").Range("i:i").Copy Destination:=Worksheets("Sheet3").Range("j:j")
j = j + 1
End If
Next z
Next i
End Sub
With this code I get runtime error 1004.
This is my first time working with VBA.
This can be simplified to one loop with CountIf (untested, but I think I got everything). You could also use Match if you prefer that.
Sub XDDXH()
Dim lookInRng as Range
Set lookInRng = Worksheets("Sheet2").Range("H8:H731")
Dim sourceRng as Range
Set sourceRng = Worksheets("Sheet1").Range("A2:A3318")
Dim rng as Range
For Each rng in sourceRng
If Application.CountIf(lookInRng, rng.Value) > 0 Then
Dim j as Long
j = j + 1
rng.EntireRow.Copy Destination:=Worksheets("Sheet3").Range("A" & j)
End If
Next rng
End Sub
Will implement a couple changes and consolidate the general consensus from comments:
'"As Integer" will get silently converted to "As Long" so just start with Long to save processing power
Dim i As Long, j as long, z as long
Dim ws1 as Worksheet, ws2 as Worksheet, ws3 as Worksheet
'setting sheets to just be cleaner and easier to write
set ws1 = Sheets(1) 'using the index, but could be Sheets("sheet1"), etc.
set ws2 = sheets(2)
set ws3 = sheets(3)
j = 1 'need this or you'll default to j=0 which doesn't work for a range in excel
For i = 2 To 3318
For z = 8 To 731
If ws1.Cells(i, 1).Value = ws2.Cells(z, 8).Value Then
ws1.Rows(i).Copy Destination:=ws3.Rows(j)
j = j + 1
End If
Next z
Next i
Note that Range("A1") and Cells(1,1) are syntactically different ways of saying the same thing. Be careful to not interchange those.
If utilizing a variable, you do not use quotations, e.g., variable j is iterated on a new sheet and you wouldn't write Range("j:j") as that will be the whole column 'J in the worksheet (yes, lowercase doesn't technically matter for that).
I'm creating a loop that is supposed to find cells that have dates before 01/01/2019 and if they find they delete the entire row.
The problem is that if they delete per example row number 2, the code is passing to row 3, but since row 2 was deleted previously the original row 3 would be skipped.
I wrote the loop and tried to add "i = 1 - 1" but the excel never stops running the code and blocks the program
Dim ws As Worksheet
Dim Ldate As Date
Dim N As Long
Ldate = "01/01/2019"
N = ws.Cells(Rows.Count, 8).End(xlUp).Offset(0, 0).Row
For i = 1 To N
If ws.Cells(i, 8).Value < Ldate Then
ws.Rows(i).Delete
' i = 1 - 1
End If
Next i
Don't let Excel guess if this string "01/01/2019" is mm/dd/yyyy or dd/mm/yyyy Never use strings to write a date, instead always use real dates: Ldate = DateSerial(2019, 1, 1) to create dates. String-Dates are very evil! The only use case to cast a real date into a string is to print it on paper or screen. All other cases must use real dates (number formats) to be reliable.
.Offset(0, 0) is usless remove it. Moving 0 rows and 0 columns from current cell will not change current cell at all.
If you delete/add rows then your loops must be backwards in order to row count correctly: For iRow = LastRow To 1 Step - 1
So you end up with something like this
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim Ldate As Date
Ldate = DateSerial(2019, 1, 1)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 8).End(xlUp).Row
Dim iRow As Long
For iRow = LastRow To 1 Step - 1
If ws.Cells(iRow , 8).Value < Ldate Then
ws.Rows(iRow).Delete
End If
Next iRow
Alternative if you use a forward loop, you need to collect the rows to delete in a Range variable and delete it at once after the loop is finished. This way deleting doesn't affect the row counting inside the loop (because we delete after the loop):
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim Ldate As Date
Ldate = DateSerial(2019, 1, 1)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 8).End(xlUp).Row
Dim RowsToDelete As Range
Dim iRow As Long
For iRow = 1 To LastRow
If ws.Cells(iRow , 8).Value < Ldate Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = ws.Rows(iRow)
Else
Set RowsToDelete = Union(RowsToDelete, ws.Rows(iRow))
End If
End If
Next iRow
If Not RowsToDelete Is Nothing Then
RowsToDelete.Delete
End If
Actually this approach should be faster because it only performs one delete action in the end (instead of one per deleted row).
Edit according comments:
Test if a worksheet exists before you use it.
Option Explicit
Function WorksheetExists(ByVal WorksheetName As String, Optional ByVal InWorkbook As Workbook) As Boolean
'default workbook is ThisWorkbook
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook
End If
Dim ws As Worksheet
On Error Resume Next
Set ws = InWorkbook.Worksheets(WorksheetName)
On Error GoTo 0
WorksheetExists = Not ws Is Nothing
End Function
Then use it like
If WorksheetExists("Sheet1") Then …
'or to test for a worksheet in a different workbook
If WorksheetExists("Sheet1", Workbooks("OtherWorkbook.xlsx")) Then
The simplest way is to change
For i = 1 To N
to
For i = N To 1 step -1
This way when your row is deleted it will not change the number of the following rows as these will be lower numbered rows.
My code loops through rows and columns and performs an action. I want to loop to the first empty column, however,
my code keeps looping past this column. My sheet currently looks something like this:
A----------1----------blank---------A---------1
B----------2----------blank---------C---------4
C----------3----------blank---------W---------2
In the above example, I want to loop from k = 1 to the first empty column, which is k = 3 (i.e. only extract data from the first 2 columns then stop the loop).
This is my current code:
Option Explicit
Sub exitemptycolumn()
Dim lastcolumn As Long
Dim lastrow As Long
Dim sh As Worksheet
Dim rng As Range
Set sh = Sheets("sheetname")
lastcolumn = sh.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
lastrow = sh.Cells(Rows.Count, 1).End(xlUp).Row
For k = 7 to lastcolumn
for j = 1 TO lastrow
set rng = sh.Range(columns(1), Columns(k))
If Application.WorksheetFunction.CountA(sh.Cells(1, k).EntireColumn) = 0 then Exit For
'rest of code
Next j
Next k
End Sub
To answer the question, you want to end your loop through columns as soon as the column is completely empty.
We can use Application.WorksheetFunction.CountA to do the check like so:
For k = 7 to lastcolumn
set rng = sh.Range(columns(1), Columns(k))
If Application.WorksheetFunction.CountA(sh.Cells(1, k).EntireColumn) = 0 then Exit For
Next k
it's been a while since I've used VBA. I have a range of unique values that I would like to search a table for. And if those values exist in said table, delete the entire row.
I'm able to loop through and delete specific, singular values, but struggling with multiple. I have tried replacing "30ExGEPAc30Q4" (code below) with Range() and an array, but can't quite get it. Here's what I've got so far:
Sub test()
Dim x As Long
Dim lastrow As Long
lastrow = Sheets("LRP").ListObjects("Data_LRP").Range.Rows.Count
Worksheets("LRP").Activate
For x = lastrow To 1 Step -1
If Cells(x, 1).Value = "30ExGEPAc30Q4" Then
Rows(x).Delete
End If
Next x
End Sub
If I understand you correctly, this is what you're trying to achieve; I have cleaned up some of the unnecessary bits and now you just have to edit x and lastrow as is necessary.
Sub test()
Dim x As Long
Dim lastrow As Long
'lastrow = Sheets("LRP").ListObjects("Data_LRP").Range.Rows.Count
x = 1
lastrow = 21
'Worksheets("LRP").Activate
Do While x <= lastrow
' For x = lastrow To 1 Step -1
If Cells(x, 1).Value = "30ExGEPAc30Q4" Then
Rows(x).Delete
lastrow = lastrow - 1
Else
x = x + 1
End If
' Next x
Loop
End Sub
For those curious, it ended up looking like this. Thanks for all the help!
Sub Cull()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht1row As Long
Dim sht2row As Long
Dim sht2total As Long
Dim DupID As String
Set sht1 = Worksheets("Data Form")
Set sht2 = Worksheets("LRP")
sht2.Activate
sht2total = Worksheets("LRP").ListObjects("Data_LRP").Range.Rows.Count
sht1row = 33
Do While sht1.Cells(sht1row, 2).Value <> ""
DupID = sht1.Cells(sht1row, 2).Value
For sht2row = 2 To sht2total
If DupID = Cells(sht2row, 1).Value Then
Rows(sht2row).Delete
sht2row = sht2row - 1
Exit For
End If
Next
sht1row = sht1row + 1
Loop
End Sub
Everything in this code works well until the piece where I need to delete the rows in column "I" of the source tab ("Status Report"). I have to run this macro several times to clear out all of the rows I want to delete because it appears to only delete one row at a time.
How can I get this macro to delete all of the rows I want and only run this code once?
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Status Report")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("I1:I1000") ' Do 1000 rows
If c = 1 Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
Source.Rows(c.Row).EntireRow.Delete
End If
Next c
End Sub
Thanks for your help!
How is this? It, as suggested by #yass, starts at the last row and works backwards.
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Dim lastRow As Long
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Status Report")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
blankRow = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row ' Start copying to row 1 in target sheet
lastRow = 1000
' lastRow = Source.Cells(Source.Rows.Count, 9).End(xlUp).Row ' Uncomment this line if you want to do ALL rows in column I
With Source
For i = lastRow To 1 Step -1
If .Cells(i, 9).Value = 1 Then
If blankRow = 1 Then
.Rows(i).Copy Target.Rows(blankRow)
Else
.Rows(i).Copy Target.Rows(blankRow + 1)
End If
blankRow = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row
.Rows(i).EntireRow.Delete
Next i
End With
End Sub
Note: The main difference is the For loop. AFAIK you can't do a For each x in Range loop backwards.