I have the following VBA script, which was simply built to delete the entire row, if a value in Col T is 2. The problem is my dataset is usually large (200k lines +). Is there any way I can speed up this process, or write the script better? The Sheet name is "NonSerial".
Sub DeleteRows()
Dim lr As Long, lr2 As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "T").End(xlUp).Row
Columns("T:T").AutoFilter
ActiveSheet.Range("$T$1:$T$" & lr).AutoFilter Field:=1, Criteria1:="2"
lr2 = Cells(Rows.Count, "T").End(xlUp).Row
If lr2 = 2 Then Exit Sub
Application.DisplayAlerts = False
ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
Application.DisplayAlerts = True
Range("T1").AutoFilter
Application.ScreenUpdating = True
End Sub
Related
i can copy whole rows but finding it difficult to locate the end cell of the row N and then copy everything from N2 to last the row. The end of the row - N ( cell) changes in length as the data imported changes
Sub Copy_To_Lastrow()
Application.ScreenUpdating = False
Dim Lastrow As Long
Sheets("Meeting1").Select
Range("N2").Select
Lastrow = Cells(Rows.Count, "AN").End(xlUp) + 1
Range("n2").Copy Cells(Lastrow, "AN")
'Lastrow = Cells(Rows.Count, "AN").End(xlUp).Row + 1
'Range("n2").Copy Cells(Lastrow, "AE")
'Lastrow.PasteSpecial xlPasteValues
Range(Lastrow).PasteSpecial.Values
Application.ScreenUpdating = True
End Sub
One way, avoiding any copy/paste:
Sub Copy_To_Lastrow()
Dim lr As Long
With Worksheets("Meeting1") '<<should specify a workbook here...
lr = .Cells(.Rows.Count, "AN").End(xlUp).Row
.Range("N2:N" & lr).Value = .Range("N2").Value
End With
End Sub
I have this VBA code which is used to consolidate the different tabs to one single sheet.Now the issue here is its taking too long to copy each line item to one single sheet. Need an update so that i could set print area as range and copy the sheets back to one.
ActiveWorkbook.Worksheets("Master Sheet").Activate
Rows("2:" & Rows.Count).Cells.ClearContents
totalsheets = Worksheets.Count
For i = 1 To totalsheets
If Worksheets(i).Name <> "Master Sheet" Then
lastrow = Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To lastrow
Worksheets(i).Activate
Worksheets(i).AutoFilterMode = False
Worksheets(i).Rows(j).Select
Selection.Copy
Worksheets("Master Sheet").Activate
lastrow = Worksheets("Master Sheet").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Master Sheet").Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next
End If
Next
MsgBox "Completed"
ActiveWorkbook.Save
End Sub
First of all, avoid selecting worksheets and cells: Worksheets(i).Activate, Rows(j).Select. This is the most time-consuming. Usually it can be replaced with direct links.
Next, don't repeat Worksheets(i).AutoFilterMode = False inside the loop for j, it will be enough to do it once before For j = 2 To lastrow.
Third, don't copy row-by-row. Instead, copy the entire sheet:
Dim lastCell As Range
Set lastCell = Sheets("Sheet1").Range("A1").SpecialCells(xlLastCell)
Sheets("Sheet1").Range(Range("A1"), lastCell).Copy
Try this code, please. It it is fast, working mostly in memory, using arrays:
Sub testConsolidate()
Dim sh As Worksheet, shM As Worksheet, lastRowM As Long, arrUR As Variant
Set shM = ActiveWorkbook.Worksheets("Master Sheet")
shM.Rows("2:" & Rows.Count).Cells.Clear
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Master Sheet" Then
sh.AutoFilterMode = False
lastRowM = shM.Cells(Cells.Rows.Count, 1).End(xlUp).row
arrUR = sh.UsedRange.Offset(1).value 'copy from row 2 down
shM.Cells(lastRowM + 1, 1).Resize(UBound(arrUR, 1), _
UBound(arrUR, 2)).value = arrUR
End If
Next
MsgBox "Completed"
ActiveWorkbook.Save
End Sub
I'm creating a tool that needs to delete rows that in the column "E" have dates older than 01-01-2019.
Sub OlderDateDelete()
Dim i As Variant
Application.DisplayAlerts = False
For i = Sheets("Iberica Not Sent").Count To 2 Step -1
If Sheets(i).Range("E2").Value < DateValue("01/01/2019") Then
Sheets(i).Delete
End If
Next i
Application.DisplayAlerts = True
End Sub
Watch this lines:
If Sheets(i).Range("E2").Value < DateValue("01/01/2019") Then
Sheets(i).Delete
End If
Those lines will delete your sheet.
I think you should edit it instead as:
If Rows(i).Range("E2").Value < DateValue("01/01/2019") Then
Rows(i).Delete
End If
The easiest I come up with is to put the date "01/01/2019" in a cell, in my example in "G1"
Then convert each range to this cell and delete them:
Sub DeletePreviousYears()
Dim i As Long
Dim LastRow As Long
LastRow = Sheets("Iberica Not Sent").Range("E" & Rows.Count).End(xlUp).Row
Application.DisplayAlerts = False
For i = LastRow To 2 Step -1
If Range("E" & i) <> "" And Range("E" & i).Value < Range("G1").Value Then
Rows(i).Delete
End If
Next i
Application.DisplayAlerts = True
End Sub
The best would also be to use a Function to find the Last Row and come back up with your loop.
Also with your first code using Sheets, you were looping through sheets and not row.
This is to answer your written question. You can use an Autofilter then delete all the visible data except the header row.
With Sheets("Iberica Not Sent")
.AutoFilterMode = False
With Range("A1").CurrentRegion
.AutoFilter Field:=5, Criteria1:="<01/01/2019"
On Error Resume Next
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
Or, you can loop like this
Dim lr As Long
Dim i As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 2 Step -1
If Cells(i, "E") < DateValue("01/15/2019") Then
Cells(i, "E").EntireRow.Delete
End If
Next i
I prefer to use a filter.
I have code to archive data from "sheet1" to "sheet2". It overwrites existing data in the "sheet2" rows from the previous archive exercise.
How do I have it seek the next blank row vs. overwriting existing data?
I have two header rows so it should commence with row 3.
Option Explicit
Sub Archive()
Dim lr As Long, I As Long, rowsArchived As Long
Dim unionRange As Range
Sheets("sheet1").Unprotect Password:="xxxxxx"
Application.ScreenUpdating = False
With Sheets("sheet1")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For I = 3 To lr 'sheets all have headers that are 2 rows
If .Range("AB" & I) = "No" Then
If (unionRange Is Nothing) Then
Set unionRange = .Range(I & ":" & I)
Else
Set unionRange = Union(unionRange, .Range(I & ":" & I))
End If
End If
Next I
End With
rowsArchived = 0
If (Not (unionRange Is Nothing)) Then
For I = 1 To unionRange.Areas.Count
rowsArchived = rowsArchived + unionRange.Areas(I).Rows.Count
Next I
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
unionRange.EntireRow.Delete
End If
Sheets("sheet2").Protect Password:="xxxxxx"
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Operation Completed. Total Rows Archived: " & rowsArchived
End Sub
Change
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
... to,
with worksheets("sheet2")
unionRange.Copy _
Destination:=.Cells(.rows.count, 1).end(xlup).offset(1, 0)
end with
This is like starting at the bottom row of the worksheet (e.g. A1048576) and tapping [ctrl+[↑] then selecting the cell directly below it.
The With ... End With statement isn't absolutely necessary but it shortens the code line enough to see it all without scolling across. unionRange has been definied by parent worksheet and cell range so there is no ambiguity here.
I'd propose the following "refactoring"
Option Explicit
Sub Archive()
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = Sheets("sheet1")
Set sht2 = Sheets("sheet2")
sht1.Unprotect Password:="xxxxxx"
With sht1.Columns("AB").SpecialCells(xlCellTypeConstants).Offset(, 1) '<== change the offset as per your need to point to whatever free column you may have
.FormulaR1C1 = "=if(RC[-1]=""NO"","""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
.EntireRow.Copy Destination:=sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Offset(1, 0)
MsgBox "Operation Completed. Total Rows Archived: " & .Cells.Count
End With
.ClearContents
End With
sht2.Protect Password:="xxxxxx"
End Sub
just choose a "free" column in "Sheet1" to be used as a helper one and that'll be cleared before exiting macro. In the above code I assumed it's one column to the right of "AB"
The following approach worked for me! I'm using a button to trigger macro.
Every time it takes the last row and append it to new sheet like a history. Actually you can make a loop for every value inside your sheet.
Sub copyProcess()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim source_last_row As Long 'last master sheet row
source_last_row = 0
source_last_row = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Set copySheet = Worksheets("master")
Set pasteSheet = Worksheets("alpha")
copySheet.Range("A" & source_last_row, "C" & source_last_row).copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Please help - I've been searching for hours and am having no luck!
I'm using Power Query to bring in results from a SQL script. This information updates everytime I open the spreadsheet. Once the information has updated, I would like to delete Rows which have a date in Column C that is greater than today, so they don't get calculated in my VLOOKUP on another sheet.
I've tried the following:
Private Sub Workbook_Open()
Dim LR As Long, I As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LR = Range("C" & Rows.Count).End(xlUp).Row
For I = LR To 1 Step -1
If Range("C" & I).Value > Date Then Rows(I).Delete
Next I
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
This however doesn't run automatically, and when running it manually it gives "Run-time error '1004': Application-defined or object-defined error" and then proceeds to delete incorrect dates.
I also tried this, but it also deletes the incorrect dates and gives me Run-time error.
Sub DeleteCells()
Dim LR As Long, I As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LR = Range("C" & Rows.Count).End(xlUp).Row
For I = LR To 1 Step -1
If Range("C" & I).Value > Date Then Rows(I).Delete
Next I
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
EDIT 4/11: I am guessing that the 1004 error occurred because all of the "Branch Not Open" rows had been previously removed. The updated code below wraps an if statement around the autofilter step, which should now only be applied if at least one match for "Branch Not Open" is found in the filter range. Hopefully this version works!
#SickDimension is off to a great start -- but since you know that a number of rows are going to have "Branch Not Open" listed in the "Live Date" column you can remove them quickly using the autofilter. Try this code out (with an update for the LR code too):
Private Sub Workbook_Open()
Dim LR As Long, LC As Long, I As Long
Dim FilterRng As Range
Dim DataSheet As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'assign worksheet to save time in references
Set DataSheet = ThisWorkbook.Worksheets("Clocking Exceptions")
'Define your filter range as the block of data
LC = DataSheet.Range("A3").End(xlToRight).Column
With DataSheet
LR = .Range("C" & .Rows.Count).End(xlUp).Row
End With
Set FilterRng = Range(DataSheet.Cells(3, 1), DataSheet.Cells(LR, LC))
'autofilter the sheet to remove "Branch Not Open" rows
If Not FilterRng.Find(What:="Branch Not Open", LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
With FilterRng
.AutoFilter Field:=3, Criteria1:="Branch Not Open", Operator:=xlAnd
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
DataSheet.AutoFilterMode = False
End If
For I = LR To 1 Step -1
If IsDate(DataSheet.Range("C" & I).Value) Then
If DateValue(DataSheet.Range("C" & I).Value) > DateValue(Date) Then Rows(I).Delete
End If
Next I
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
If you need to use it upon opening file, you should specify the sheet you want it to run as upon opening file there is no range/sheet selected there for error '1004' ;) for ex.
'Following line needs to be defined more accurately
Range("C" & I).Value
'Redefine
Sheets("Sheet1").Range("C" & I).Value
Other wise the following will work, add the DateValue() to make the comparioson with the date values -
If DateValue(Range("C" & I).Value) > DateValue(Date) Then Rows(I).Delete
The solution
Private Sub Workbook_Open()
Dim LR As Long, I As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LR = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
For I = LR To 1 Step -1
If IsDate(Sheets("Sheet1").Range("C" & I).Value) Then
If DateValue(Sheets("Sheet1").Range("C" & I).Value) > DateValue(Date) Then Rows(I).Delete
End If
Next I
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub