Hi fellow communiteers,
I'm running a macro to delete entire rows that contain a certain value. The code works fine on small data sets but on the current one (~22,000 records) it consistently crashes Excel (2010). The code is below. Short of splitting the data into smaller chunks and running the macro again and again I'm not sure what to do.
Any help appreciated and here's the code:
Sub CleanOcc()
'Row counting
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim Lrow2 As Long
With Sheets("Occ_Prep")
'Cleans the occ_prep sheet ready for upload (Column and value can be changed)
Sheets("Occ_Prep").Activate
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow2 = Lastrow To Firstrow Step -1
'We check the values in the A column in this example
With .Cells(Lrow2, "K")
If Not IsError(.Value) Then
If .Value = "0" Then .EntireRow.Delete
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
End If
End With
Next Lrow2
End With
End Sub
Agree with Siddharth comment autofilter is way to go. This should be a lot quicker.
Option Explicit
Sub delrows()
Dim ws As Worksheet
Dim LR As Long
Dim rng As Range, frng As Range
Application.ScreenUpdating = False
Set ws = Sheets("dataset") '<-- Change this to name of your worksheet
With ws
LR = .Range("A" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
Set rng = .Range("A1:C" & LR) '<-- Assuming K is the last column
rng.AutoFilter 3, "0" '<-- 11 referes to Column K
Set frng = rng.Offset(1, 0).SpecialCells(xlCellTypeVisible) '<-- Don't delete the header
frng.EntireRow.Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Edit: I just cleaned ~20000 rows (3 columns) of data in ~5 seconds. Obviously it depends how many matches there are too.
Related
I'm trying to match two columns in two worksheets. If they match I want the row from sheet 1 to replace the row in sheet 2.
I came close but now I need to overwrite this row.
I tried selection.paste but that did not work.
I tried this:
Sub Loop_Example()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Sheets("Mutatie overzicht bezetting").Range("B5:AC5").Select
Selection.Copy
Sheets("BEZETTING 2020").Activate
With ActiveSheet
.Select
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "B")
If Not IsError(.Value) Then
If .Value = Sheets("Mutatie overzicht bezetting").Range("C5") Then .EntireRow.Select
End If
End With
Next Lrow
End With
End Sub
As stated by SJR, your syntax is way off on the third line. Also you're missing sheet references, making your code fairly confusing. Please see below code to be a closer approximation to what you need:
Sub LoopThroughCities()
Dim LstRw As Long, ThsRw As Long, ThsEMPLOYEE As String
With Sheets("Bezetting 2020")
LstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
ThsEMPLOYEE = InputBox("Which employee do you want to search for?")
If Len(ThsEMPLOYEE) = 0 Then Exit Sub
For ThsRw = 2 To LstRw
With Sheets("Sheettocopyfrom")
If .Cells(ThsRw, 5).Value = ThsEMPLOYEE Then .Cells(ThsRw, 22).Resize(, 3).Copy Sheets("Sheettocopyto").Cells(ThsRw, 22)
End With
Next
End Sub
Would you know what is the following code adjustment needed. Range I have set up (A1:B20) changes over time. The first block of data stays be between A1:B20 and the second block of data always will be between A25:B60. Ranges will change over time. First block of data could reach 200 rows going down. After my code reaches the second block of data and my range falls between that block of data it picks up the range only if I have adjusted manually the range. Please note, Second block of data normally provides duplicates from the first block.
How could I have my code automatically select the first block of data past my range output without having to adjust the "range" manually?
Sub CopyPaste()
Dim lastRow As Long
Dim Sheet2 As Worksheet
Dim Results As Worksheet
Dim LookupLastrow As Long
'code line will set values from sheet
("Sheet1") into ("Sheet2") starting 5 rows down.
Set Results = Sheets("Sheet2")
lastRow = ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End (xlUp).row
Range("A1:B20" & lastRowcount).Copy
Results.Range("A" & lastRow + 5).PasteSpecial xlPasteValuesAndNumberFormats
Application.GoTo ActiveSheet.Range("A1"), True
Application.CutCopyMode = False
End Sub
Think simple. No need to build strings for range addresses, and no need for using the clipboard with .Copy and .Paste. Use a direct assignment to the .Value property in a table of cells.
Public Sub CopyValues()
Dim r_src As Range, r_dst As Range
' Source starts at row 20
Set r_src = Sheets("Sheet 2").Cells(20, 1)
' Destination starts at row 5
Set r_dst = Sheets("Sheet 1").Cells(5, 1)
Dim n As Long
' Count the non-empty cells
n = r_src.Range(r_src, r_src.End(xlDown)).Rows.Count
' Copy n rows and 2 columns with one command
r_dst.Resize(n, 2).Value = r_src.Resize(n, 2).Value
End Sub
Based on the picture you showed, the following code will capture the entire top and bottom sections, regardless of how many lines or columns exists. This assumes your top section will start in "A8" as shown. You can edit the code to reflect your actual sheet names.
Sub CopyPaste()
Dim OrigLastRow As Long
Dim OrigLastCol As Long
Dim DestLastRow As Long
Dim OrigRng As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Origin")
Set ws2 = ThisWorkbook.Worksheets("Destination")
OrigLastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
OrigLastCol = ws1.Cells(10, Columns.Count).End(xlToLeft).Column
DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5
Set OrigRng = ws1.Range(ws1.Cells(8, 1), ws1.Cells(OrigLastRow, OrigLastCol))
OrigRng.Copy
ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub
The version below creates a top and bottom section like your picture and copies both sections separately with a 5 row gap in the destination.
Sub CopyPaste2()
Dim OrigLastRow As Long
Dim OrigLastCol As Long
Dim TopLastRow As Long
Dim BotLastRow As Long
Dim DestLastRow As Long
Dim OrigTopRng As Range
Dim OrigBotRng As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Origin")
Set ws2 = ThisWorkbook.Worksheets("Destination")
'Assumes contiguous data from row 8 down
TopLastRow = ws1.Cells(8, 1).End(xlDown).Row
BotLastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
OrigLastCol = ws1.Cells(10, Columns.Count).End(xlToLeft).Column
DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5
'Assumes we are starting the top range in row 8
Set OrigTopRng = ws1.Range(ws1.Cells(8, 1), ws1.Cells(TopLastRow, OrigLastCol))
'Columns I & J as shown in the picture
Set OrigBotRng = ws1.Range(ws1.Cells(TopLastRow + 5, 9), ws1.Cells(BotLastRow, 10))
OrigTopRng.Copy
ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
'Recalculate destination last row
DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5
OrigBotRng.Copy
ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub
I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.
Thank you very much in advance!
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
Sheets("Sheet3").Select.Paste
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub DelDupsTwoLists()
Dim lastRowWs1 As Long, lastRowWs2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
lastRowWs1 = LastRow(ws1.Name, 1)
lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5
Dim myCell1 As Range, myCell2 As Range
Dim ws1Range As Range, ws2Range As Range
Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))
Dim rangeToDelete As Range
For Each myCell1 In ws1Range
For Each myCell2 In ws2Range
If myCell1.Value = myCell2.Value Then
Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)
If Not rangeToDelete Is Nothing Then
Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
Else
Set rangeToDelete = myCell2.EntireRow
End If
End If
Next
Next
If Not rangeToDelete Is Nothing Then
Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
rangeToDelete.Delete
End If
Debug.Print "Done!"
End Sub
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete, which saves a lot of time.
Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range, using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete.
Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.
Additionally:
Using Integer is not a great idea in VBA.
"_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
How to avoid using Select in Excel VBA
Give this a try (see comments in code for more details):
Sub DelDups_TwoLists()
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use
With wsSrc
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
End With
With .Sheets("Sheet2")
Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
End With
End With
With wsDst
For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet
.Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
Exit For 'exit early here if there is a match, go to next row to check
End If
Next R2
Next R1
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I am trying to determine 'lastrow' of the sheet that the macro is being run on.
I am working with two sheets. Sheet1 has about 150 rows of data and Sheet 2 only has two.
I expected that when I selected Sheet2 and assigned lastrow that it would take the count of rows from Sheet2, instead it is storing the row count from sheet1.
sub row_count()
dim lastrow as long
lastrow = Range("A" & Rows.Count).End(xlUp).row
if lastrow = 150 then
with sheets("sheet2")
.select
lastrow = Range("A" & Rows.Count).End(xlUp).row
msgbox lastrow '<----- Always returns the value of sheet1 instead of sheet2.
end with
end sub
You're using a With block, which means the program sees anything between 'With' and 'End With' as being prefixed by whatever you put after the keyword 'With', so to modify your code in place for sheet2 only:
Sub row_count()
Dim lastrow As Long
lastrow = Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row
If lastrow = 150 Then
With Sheets("sheet2")
' .Select = Sheets("sheet2").Select
.Select
' .Range = Sheets("sheet2").Range
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
MsgBox lastrow
End With
End Sub
If you want the code to run on the currently visible sheet you should change it to use the ActiveSheet property:
Sub row_count()
Dim lastrow As Long
lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If lastrow = 150 Then
With ActiveSheet ' use the currently visible sheet
.Select
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
MsgBox lastrow
End With
End Sub
However, there are some ways to improve this code: for flexibility you could pass the worksheet as a parameter. Also, your End function might return the first used row if there is already data in the last used row (it's the same as clicking in the last row and pressing Ctrl & the up arrow, so you should start in a cell below that). Lastly, you do not need to select the sheet to get the last row:
Sub GetRowCounts()
row_count Sheets("sheet1")
row_count Sheets("sheet2")
End Sub
Sub row_count(ws As Worksheet)
Dim lastrow As Long
lastrow = ws.Range("A1000000").End(xlUp).Row
MsgBox lastrow
End Sub
I think these examples are the easiest to follow.
Sub FindingLastRow()
'PURPOSE: Different ways to find the last row number of a range
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Using UsedRange
sht.UsedRange 'Refresh UsedRange
LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
'Using Table Range
LastRow = sht.ListObjects("Table1").Range.Rows.Count
'Using Named Range
LastRow = sht.Range("MyNamedRange").Rows.Count
'Ctrl + Shift + Down (Range should be first cell in data set)
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
End Sub
https://www.thespreadsheetguru.com/blog/2014/7/7/5-different-ways-to-find-the-last-row-or-last-column-using-vba
Keep an open mind though, there are lots of ways to do this same kind of thing.
If this statement...
lastrow = Range("A" & Rows.Count).End(xlUp).row
... really always returns the last row of Sheet1 instead of last row of Sheet2, then that is because you are looking at your Workbook open at Sheet1 all the time.
Whenever you have a Range or Cells statement like the above ( Range(...) ) without an explicit reference to a Worksheet, then ActiveSheet is what it is referenced to.
So to avoid that, this is what you do:
Dim Sht_1 as Worksheet
Dim Sht_2 as Worksheet
Dim Sht_1_Lastrow as Long
Dim Sht_2_Lastrow as Long
Set Sht_1 = ActiveWorkbook.Worksheets(1)
Set Sht_2 = ActiveWorkbook.Worksheets(2)
Sht_1_Lastrow = Sht_1.Range("A" & Sht_1.Rows.Count).End(xlUp).Row
Sht_2_Lastrow = Sht_2.Range("A" & Sht_2.Rows.Count).End(xlUp).Row
or
Sht_1_Lastrow = Sht_1.Cells(Sht_1.Rows.Count, "A").End(xlUp).Row
Sht_2_Lastrow = Sht_2.Cells(Sht_2.Rows.Count, "A").End(xlUp).Row
Above code block highlights the difference that makes a LastRow Variable explicitly tied to a certain Worksheet...
This way your problem cannot happen...
I'm a complete beginner attempting a macro for the first time. I want to remove entire rows of a sheet if the date in column K does not equal today's date. Outside of the code having some sort of syntax error that I can't remedy, I believe the data dump's Column K is not formatted as a date to capture the code I'm trying to run.
Here is the code I have so far. Please be gentle on someone who is trying to self teach using online resources :)
Sub GetTodaysPopulation()
Dim MySheet As Worksheet, MyRange As Range
Dim LastRow As Long, LastCol As Long
Application.DisplayAlerts = False
Set MySheet = ThisWorkbook.Worksheets("TradeExData")
ThisWorkbook.Worksheets("TradeExData").Activate
With MySheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Range("A" & .Columns.Count).End(xlToLeft).Column
Set MyRange = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
With MyRange
.AutoFilter([Field:=11], [Criteria1: <> Date])
.SpecialCells(xlCellTypeVisible).Offset(1, 0).Resize(.Rows.Count).Rows.Delete
End With
With MySheet
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
End Sub