I delete rows based on the date in a column.
The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.
I'm not sure if this is due to poorly written code or the size of the dataset.
Sub DeleteCurrentPeriod()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Transaction list by date")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Insert column, autofill formula for range
Sheets("Transaction list by date").Select
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
You can give this a try (use F8 key to run it step by step)
Some suggestions:
Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps
Read about avoiding select and activate here
Code:
Public Sub DeleteCurrentPeriod()
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim transactionSheet As Worksheet
Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
' Turn off autofilter and show all data
transactionSheet.AutoFilterMode = False
' Find last row
Dim lastRow As Long
lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
' Define range to be filtered
Dim targetRange As Range
Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
' Insert column
transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Add formula & calculate
transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Application.Calculate
'Filter on new column for cells matching criteria
transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'Delete added column and remove filter
transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
' Remove filter
transactionSheet.AutoFilterMode = False
'Select A1
Range("A1").Select
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.
'Insert column, autofill formula for range
Dim x as Long, y, lastrow
Sheets("Transaction list by date").Select
'Find the last row used
With Sheets("Transaction list by date")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
' Get the constant and perform the comparison, add "Y" to TRUE cells
x= Worksheets("Control").Cells(20,7).value
For y = 1 to lastrow
If Worksheets("Transaction list by date").Cells(y,44)>x then _
Worksheets("Transaction list by date").Cells(y,44).value = "Y"
Next y
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Worksheets("Sheet1").UsedRange
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Date
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Worksheets("Sheet1").UsedRange = aNew
End Sub
This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.
Related
I need to speed up this macro & to avoid specifying a range as (A2:A2000) for example because my data is dynamic.
My macro checks every cell with the same value in some columns to merge it
Sub Merge_Duplicated_Cells()
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Cell As Range
' Merge Duplicated Cells
Application.DisplayAlerts = False
Sheets("1").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
CheckAgain:
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
Sheets("2").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
ActiveWorkbook.Save
MsgBox "Report is ready"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
For a quick fix add
Application.Calculation = xlManual
after your code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
and
Application.Calculation = xlAutomatic
after your code
Application.DisplayAlerts = True
Application.ScreenUpdating = True
and to improve the macro not processing blank ranges,
dim ws as worksheet
dim lastrowA, lastrowB, lastrow C as long
'Instead of setting last row to 2000, can use the actual last row by eg:
'find last row of data in column A'
lastrowA = ws.Cells(Rows.Count, 1).End(xlUp).Row
'find last row of data in column B'
lastrowB = ws.Cells(Rows.Count, 2).End(xlUp).Row
'find last row of data in column C'
lastrowC = ws.Cells(Rows.Count, 3).End(xlUp).Row
and insert these into the macro instead of 2000 eg:
Set myrange = Range("A2:A" & lastrowA & ,
The slowdown in your code is primarily due to the presence of the GoTo CheckAgain transition, due to which the cycle of processing the same cells is repeated many times. In addition, multiple calls to the cells of the sheet are used, which is very time consuming. In the code below, unnecessary cycles are excluded, reading data from the sheet, merging and formatting cells are performed immediately for the entire processed subrange.
I ran the code on 2 sheets with 10000 rows each, it took 2.6 sec.
Option Explicit
Sub test1()
'Here we indicate only the starting cells in each column, because
'the size of the non-empty area in these columns is calculated
'automatically in the MergeCells() procedure
MergeCells Sheets("1").Range("A2,B2,L2,M2,N2,O2")
MergeCells Sheets("2").Range("A2,B2,L2,M2,N2,O2")
End Sub
Sub MergeCells(myrange As Range)
Dim v As Variant, col As Range, Cell As Range, toMerge(0 To 1) As Range, k As Long, index As Byte, area As Variant, arr As Variant, skip As Boolean
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
For Each col In myrange
' next line reads all the data from sheet's column at once
arr = col.Resize(myrange.Parent.Cells(Rows.Count, col.Column).End(xlUp).Row - col.Row + 1)
For k = LBound(arr, 1) To UBound(arr, 1) - 1 'loop through all rows of an array
If Not skip And arr(k, 1) = arr(k + 1, 1) And Not IsEmpty(arr(k, 1)) Then
'to prevent "gluing" adjacent sub-ranges within the same range,
'two ranges are used in the toMerge array, all odd sub-ranges are collected
'in the element with index 0, all even ranges are collected in the element
'with index 1, and Index switches from 0 to 1 and vice versa after each array subrange
If toMerge(index) Is Nothing Then
Set toMerge(index) = col.Offset(k - col.Row + 1).Resize(2)
Else
Set toMerge(index) = Union(col.Offset(k - col.Row + 1).Resize(2), toMerge(index))
End If
index = 1 - index
skip = True ' if merged, skip next cell
Else
skip = False
End If
Next
' if the ranges for merge are non-empty, we merge and format simultaneously for all subranges
For Each area In toMerge
If Not area Is Nothing Then
area.Merge
area.VerticalAlignment = XlVAlign.xlVAlignCenter
End If
Next
Set toMerge(0) = Nothing
Set toMerge(1) = Nothing
Next
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
If I understand you correctly .... besides the already existing answer, another way (which is not meant to be better) maybe something like this :
Before and after running the sub (please ignore the yellow fill and the border, as it is used just to be easier to see the result) like image below :
===>
Sub test()
Dim LR As Integer: Dim cnt As Integer
Dim i As Integer: Dim c As Range
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
LR = .Rows(.Rows.Count).Row
cnt = .Columns.Count
End With
For i = 1 To cnt
Set c = Cells(1, i)
Do
If c.Value <> "" And c.Value = c.Offset(1, 0).Value _
Then Range(c, c.Offset(1, 0)).Merge _
Else Set c = c.Offset(1, 0)
Loop Until c.Row > LR
Next
End Sub
LR is the last row of the used range of the active sheet.
cnt is the column count of the used range of the active sheet.
Then it loop from 1 to as many as the cnt as i variable.
Inside this loop, it create the starting cell as c variable, then do the inner loop, by checking each c within the looped column (the i in cnt) if the row below c has the same value then it merge this c and the c.offset(1,0). The inner loop stop when the c.row is larger than the LR, then it goes to the next i (the next column).
Please note, the data should start from column A ... because the outer loop assume that the column to be in the inner loop will start from column 1 (column A). And also, the code doesn't do any fancy things, such as alignment, font size, border, etc.
Good morning,
currently I have this code to delete rows without due date (Column J) and amount paid=0 (Column H).
Sub delete_rows()
Range("A1").End(xlDown).Select
Sheets("AA").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,"""",RC[-5])"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J500"), Type:=xlFillDefault
Range("J2").End(xlDown).Select
Range("K2").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "J").End(xlUp).Row To 2 Step -1
If .Cells(line, "J") = "" Then
.Rows(line).Delete
End If
Next linha
End With
Application.ScreenUpdating = True
ActiveCell.FormulaR1C1 = "=IF(RC[-4]="""","""",RC[-4])"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K500"), Type:=xlFillDefault
Range("K2").End(xlDown).Select
Range("J1").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "K").End(xlUp).Row To 2 Step -1
If .Cells(line, "K") = "" Then
.Rows(line).Delete
End If
Next line
End With
Application.ScreenUpdating = True
End sub()
I created a code with a defined number of lines...however it takes a long time for the code to run, because sometimes the number of lines is small and it always runs the 500 lines. What's the way to set the code so that it looks for the last filled row in column A, and then eliminate the rows where column H has values =0 and in column J no values?
Please check: find last cell. Also have a look at: avoid select.
Afterwards, I think you should be able to understand the following code, which should get you the required result:
Sub test()
Application.ScreenUpdating = False
'declare your variables
Dim ws As Worksheet
Dim Rng1 As Range, Rng2 As Range
Dim i As Long, lastRow As Long
Set ws = Sheets("AA")
With ws
'get last row in
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'set ranges for loop
Set Rng1 = Range(.Cells(2, "H"), .Cells(lastRow, "H"))
Set Rng2 = Range(.Cells(2, "J"), .Cells(lastRow, "J"))
'reverse loop
For i = Rng1.Rows.Count To 1 Step -1
'check conditions for cell in "H" and "J"
If Rng1.Cells(i) = 0 And Rng2.Cells(i) = "" Then
'defined ranges start at row 2, hence +1
ws.Rows(i + 1).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
My workbook has 4 tabs. I need to move data from all three tabs to a summary sheet. The code works until I add the section to pull from the second sheet. (I haven't bothered trying to pull from the 3rd sheet yet as I can't get this to work). The source range is different for all three sheets and well as the columns to copy.
This code sometimes works and sometimes doesn't. Upon first opening spreadsheet, it will work correctly the first time. Subsequent times, the data from source2 is overwriting the data from source1 starting with row 1, or it adds the data after a few blank rows.
I have tried several variations I have found in forums with the same results.
Sub SendToSummary()
Dim c As Range
Dim j As Integer
Dim k As Integer
Dim lastrow As Long
Dim Source As Worksheet
Dim Source2 As Worksheet
Dim Source3 As Worksheet
Dim Target As Worksheet
' Designations
Set Source = ActiveWorkbook.Worksheets("Pool Cleaners")
Set Source2 = ActiveWorkbook.Worksheets("Service Technicians")
Set Source3 = ActiveWorkbook.Worksheets("PCQC Bonello Commissions")
Set Target = ActiveWorkbook.Worksheets("Summary")
lastrow = Target.Range("a1").End(xlDown).Row + 1
Sheets("Summary").Cells.Clear
Sheets("Summary").Cells.Interior.ColorIndex = xlColorIndexNone
Sheets("Summary").Select
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("N:N") ' Do column N moving hours to summary sheet
If c > 0 Then
Source.Rows(c.Row).Columns("I:Q").Copy
Target.Rows(j).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
j = j + 1
End If
Next c
Sheets("Summary").Select
With ActiveSheet 'delete blank hours & headers
.AutoFilterMode = False
With Range("f1", Range("F" & Rows.Count).End(xlUp))
.AutoFilter 1, ""
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
.AutoFilter 1, "hours"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
k = lastrow
For Each c In Source2.Range("Q:Q") 'copying tech commissions over
If c > 0 Then
Source2.Rows(c.Row).Columns("k:s").Copy
Target.Rows(k).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
k = k + 1
End If
Next c
End Sub
Responding to your question in the comments:
Here:
Sheets("Summary").Select
With ActiveSheet 'delete blank hours & headers
.AutoFilterMode = False
With Range("f1", Range("F" & Rows.Count).End(xlUp)) '<<<<< here
.AutoFilter 1, ""
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
.AutoFilter 1, "hours"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
Your outer With object is Activesheet, so anything in the With block which is preceded by . is linked to that object. The Range calls in the flagged line are not explicitly tied to the With block object (since they have no .) except by "accident" because the With block object in this case is the active sheet, and unqualified Range references in a regular code module default to the ActiveSheet.
Your code "works" as long as "Summary" is active, but will break otherwise.
You could do something like this, and avoid needing to activate the sheet:
With Target 'delete blank hours & headers
.AutoFilterMode = False
With .Range("f1", .Range("F" & Rows.Count).End(xlUp)) '<<<<< here
.AutoFilter 1, ""
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
On Error Goto 0
.AutoFilter 1, "hours"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
On Error Goto 0
End With
.AutoFilterMode = False
End With
Excel 2007 [VB]
In my macro I filter by color to find duplicated values (on column "J" I have Highlight Cells Rules - Duplicates). Duplicated records in column "J" are named in column "K" as "Copy" or "Original".I would like to find "Copy" for each "Original" record which is always under (but not 1 but more rows) and copy cells value from column N:R of "Copy" row to row with "Original".
I hope I wrote it clearly but if not screenshot under.
Table
Begining of my macro:
Sub copy_original()
Dim lastRow As Long
Dim wb2 As Excel.Workbook
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = True
Set wb2 = ThisWorkbook
wb2.Sheets("Sheet1").AutoFilterMode = False
wb2.Sheets("Sheet1").Range("A4:U4").AutoFilter Field:=10, Criteria1:=RGB(255, 204, 0), Operator:=xlFilterCellColor
lastRow = wb2.Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
For x = lastRow To 5 Step -1
If...
...
wb2.Sheets("Sheet1").AutoFilterMode = False
End Sub
I looked for something similiar that can help and I found such a scripts:
Check if one cell contains the EXACT same data as another cell VBA
Find cells with same value within one column and return values from separate column of same row
Excel: Check if Cell value exists in Column, and return a value in the same row but different column
But to be honest I can't figure it out how to connect it into one working macro.
I would be gratefull for help.
Try this:
Sub copy_original()
Dim filteredRng As Range, cl As Range, rw As Integer
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("Sheet1")
.AutoFilterMode = False
.Range("A4:U4").AutoFilter Field:=10, Criteria1:=vbRed, Operator:=xlFilterCellColor
Set filteredRng = .Range("J5:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
For Each cl In filteredRng.SpecialCells(xlCellTypeVisible)
If cl.Offset(0, 1) = "Original" Then
Range("L" & rw & ":R" & rw).Copy Destination:=cl.Offset(0, 2)
End If
rw = cl.Row
Next cl
.AutoFilterMode = False
End With
End Sub
You can try that;
For x = 5 to lastRow
If Cells(x,11) = "Copy" Then
For y = x+1 to LastRow
If Cells(y,10).Value = Cells(x,10) then
Cells(y,14) = Cells(x,14)
Cells(y,15) = Cells(x,15)
Cells(y,16) = Cells(x,16)
Cells(y,17) = Cells(x,17)
Cells(y,18) = Cells(x,18)
End If
Next y
End If
Next x
I have used the below code but this takes all cells, including formula cells.
I tried to include SpecialCells(xlCellTypeVisible) , but wherever I seem to put it I cannot get it right.
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
' copy headings
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
Sheets(J).Activate ' make the sheet active
Range("A1").Select
Selection.CurrentRegion.Select ' select all cells in this sheets
' select all lines except title
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' copy cells selected in the new sheet on last line
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
Good Morning chaps,
A few days after you asked this questions I was having similar issues with a Macro similar to this Jerry Sullivan
Gave me a hand try this it might work for you.
Option Explicit
Sub CombineData()
'--combines data from all sheets
' assumes all sheets have exact same header fields as the
' first sheet; however the fields may be different order.
'--combines using copy-paste. could be modified to pasteValues only
Dim lNdxSheet As Long, lNextRow As Long, lDestCol As Long
Dim lColCount As Long, lRowCount As Long
Dim rHeaders As Range
Dim sHeader As String
Dim vMatch As Variant, vHeaders As Variant
Dim wksCombined As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'--add new sheet for results
Set wksCombined = Worksheets.Add(Before:=Worksheets(1))
'--optional: delete existing sheet "Combined"
On Error Resume Next
Sheets("Combined").Delete
On Error GoTo 0
With wksCombined
.Name = "Combined"
'--copy headers that will be used in destination sheet
Set rHeaders = Sheets(2).Range("A1").CurrentRegion.Resize(1)
rHeaders.Copy Destination:=.Range("A1")
End With
'--read headers into array
vHeaders = rHeaders.Value
lColCount = UBound(vHeaders, 2)
lNextRow = 2
For lNdxSheet = 2 To Sheets.Count
'--count databody rows of continguous dataset at A1
lRowCount = Sheets(lNdxSheet).Range("A1").CurrentRegion.Rows.Count - 1
If lRowCount > 0 Then
For lDestCol = 1 To lColCount
sHeader = vHeaders(1, lDestCol)
'--search entire first col in case field is rSourceData
vMatch = Application.Match(sHeader, Sheets(lNdxSheet).Range("1:1"), 0)
If IsError(vMatch) Then
MsgBox "Header: """ & sHeader & """ not found on sheet: """ _
& Sheets(lNdxSheet).Name
GoTo ExitProc
End If
With Sheets(lNdxSheet)
'--copy-paste this field under matching field in combined
.Cells(2, CLng(vMatch)).Resize(lRowCount).Copy
' Option 1: paste values only
wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteValues)
' Option 2: paste all including formats and formulas
' wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteAll)
End With
Next lDestCol
lNextRow = lNextRow + lRowCount
End If ' lRowCount > 0
Next lNdxSheet
ExitProc:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I'm not sure if I understood your question correctly but try this and see if it helps.