The loop stops after 4 iterations but when I run it again it does another 2 iterations and after that 1 at a time. The data can contain up to a hundred lines or more to process. Any advice would be greatly appreciated
Sub SASDAB()
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("SAS&DAB")
For i = 1 To ws.Cells(Rows.Count, "E").End(xlUp).Row
If ws.Cells(i, "E").Value = 0 Then Exit For
Sheets("Parts List").Activate
With Range("B3").Select
ActiveCell.FormulaR1C1 = "='SAS&DAB'!R[-2]C[-1]"
Range("B4").Select
ActiveCell.FormulaR1C1 = "='SAS&DAB'!R[-3]C[2]"
Range("E5").Select
ActiveCell.FormulaR1C1 = "='SAS&DAB'!R[-4]C[-2]"
Range("E6").Select
ActiveCell.FormulaR1C1 = "='SAS&DAB'!R[-5]C"
Range("E117").Select
ActiveSheet.Range("$D$6:$D$845").AutoFilter Field:=1, Criteria1:=">0", _
Operator:=xlAnd
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Sheets("SAS&DAB").Select
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'Sheets("Parts List").Select
End With
Next i
End Sub
It appears that you are deleting selected rows with each pass.
Selection.Delete Shift:=xlUp
This decreases the row count that drives the loop.
For i = 1 To ws.Cells(Rows.Count, "E").End(xlUp).Row
Related
I have a For loop that loops through integers 1 to 9 and simply finds the bottom most entry that corresponds to that integer ( i.e. 1,1,1,2,3,4,5 would find the 3rd "1" entry) and inserts a blank row. I concatenate the number with a string "FN" that just corresponds to the application for this code, just to clarify. Anyway, it works well, but it lags quite a bit for only having to run through 9 integers. I was hoping someone would be able to help me debug to improve speed on this code. Thanks!
Bonus points if anyone can shed some light on a good way to populate the blank row being inserted with a formatted copy of the header of the page that spans ("A1:L1"). The code I attempted is commented out right before Next i.
Sub test()
Dim i As Integer, Line As String, Cards As Range
Dim Head As Range, LR2 As Long
For i = 1 To 9
Line = "FN" & CStr(i)
Set Cards = Sheets(1).Cells.Find(Line, after:=Cells(1, 1), searchdirection:=xlPrevious)
Cards.Rows.Offset(1).EntireRow.Insert
Cards.Offset(1).EntireRow.Select
' Range("A" & (ActiveCell.Row), "K" & (ActiveCell.Row)) = Range("A3:K3")
' Range("A" & (ActiveCell.Row), "K" & (ActiveCell.Row)).Font.Background = Range("A3:K3").Font.Background
Next i
End Sub
This works pretty fast for me
Sub Sample()
Dim i As Long, line As String, Cards As Range
With Sheets(1)
For i = 1 To 9
line = "FN" & i
Set Cards = .Columns(6).Find(line, LookIn:=xlValues, lookat:=xlWhole)
If Not Cards Is Nothing Then
.Range("A3:K3").Copy
Cards.Offset(1, -5).Insert Shift:=xlDown
End If
Next i
End With
End Sub
Before
After
Most of your improvements will come from altering the application environment variables with the appTGGL helper function but there are a few tweaks in the base code here.
Option Explicit
Sub ewrety()
Dim f As Long, fn0 As String, fndfn As Range
'appTGGL btggl:=false 'uncomment this when you are confident in it
With Worksheets(1).Columns("F")
For f = 1 To 9
fn0 = Format$(f, "\F\N0")
Set fndfn = .Find(What:=fn0, After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
With fndfn
.Offset(1, -5).EntireRow.Insert Shift:=xlDown
.Parent.Range("A1:L1, XFC1").Copy Destination:=.Offset(1, -5)
End With
Next f
End With
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.AutoRecover.Enabled = bTGGL 'no interruptions with an auto-save
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub
Below code works great as expected the only downside is its slow because I am using this to search for all the instances of the substring and delete the Entire row if found in any cell of the whole workbook.
Aim is simple just delete the entirerow if the entered string is found in any cell string
Dim wo As Worksheet, ws As Worksheet
Dim I As Long, j As Long, m As Long
Dim toFind As String, testStr As String
Dim pos As Long
Dim lstRow As Long, cutRow As Long
Dim WS_Count As Integer
Dim Cell As Range
Option Compare Text
Option Explicit
Sub SearchDelete()
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
j = 0
If toFind = "" Then
MsgBox "Empty String Entered.Exiting Sub Now."
Exit Sub
Else
WS_Count = ActiveWorkbook.Worksheets.Count
'Begin the loop.
For I = 1 To WS_Count
Label1:
For Each Cell In Worksheets(I).UsedRange.Cells
If Trim(Cell.Text) <> "" Then
pos = 0
pos = InStr(1, Trim(Cell.Text), toFind, vbTextCompare)
If pos > 0 Then 'match Found'
cutRow = Cell.Row
Worksheets(I).Rows(cutRow).EntireRow.Delete
j = j + 1
GoTo Label1
Else: End If
Else: End If
Next Cell
Next I
End If
MsgBox "Total " & j & " Rows were deleted!"
End Sub
Individual operations are pretty much always slower than bulk operations and the Range.Delete method is no exception. Collecting the matching rows with a Union method and then performing the removal en masse will significantly speed up the operation.
Temporarily suspending certain application environment handlers will also help things along. You do not need Application.ScreenUpdating active while you are removing rows; only after you have completed the operation.
Option Explicit
Option Compare Text
Sub searchDelete()
Dim n As Long, w As Long
Dim toFind As String, addr As String
Dim fnd As Range, rng As Range
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
If Not CBool(Len(toFind)) Then
MsgBox "Empty String Entered.Exiting Sub Now."
GoTo bm_Safe_Exit
End If
'appTGGL bTGGL:=False 'uncomment this line when you have finsihed debugging
With ActiveWorkbook
For w = 1 To .Worksheets.Count
With .Worksheets(w)
Set fnd = .Cells.Find(what:=toFind, lookat:=xlPart, _
after:=.Cells.SpecialCells(xlCellTypeLastCell))
If Not fnd Is Nothing Then
Set rng = .Rows(fnd.Row)
n = n + 1
addr = fnd.Address
Do
If Intersect(fnd, rng) Is Nothing Then
n = n + 1
Set rng = Union(rng, .Rows(fnd.Row))
End If
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address
Debug.Print rng.Address(0, 0)
rng.Rows.EntireRow.Delete
End If
End With
Next w
End With
Debug.Print "Total " & n & " rows were deleted!"
bm_Safe_Exit:
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Debug.Print Timer
End Sub
The answer to your question: "How to speed up this code to find and delete rows if a substring is found" is - DON'T repeat the search from the top of the sheet after you found and removed the row!
I'd like to use excel 2010 to realize a function to first compare values from 2 different Excel sheets and then sort them based on another column value.
For example:
In sheet 1, I've got:
Name Value
Test 1 100.5
Test 1 200.6
Test 1 300.3
Test 2 100.8
Test 2 200.6
Test 3 200.5
In sheet 2, I've got :
Name
Test 1
Test 1
Test 1
Test 3
what I want to achieve is if the name from sheet 1 is not in sheet 2, delete the whole line in sheet 1 and sort by descending the name based on the column value.
Desired:
Name Value
Test 1 300.3
Test 1 200.6
Test 1 100.5
Test 3 200.5
Here is what I get so far:
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer, j As Integer
Dim lastRow1 As Integer, lastRow2 As Integer
On Error GoTo 0
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
lastRow1 = ws1.UsedRange.Rows.Count
lastRow2 = ws2.UsedRange.Rows.Count
For i = 2 To lastRow1
For j = 2 To lastRow2
If ws1.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, ws2.Cells(j, 1).Value, ws1.Cells(i, 1).Value, vbTextCompare) < 1 Then
Rows(i).EntireRow.delete
Exit For
End If
End If
Next j
Next i
End Sub
Please suggest and help. thank you very much in advance.
I changed your code so it is working:
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer, j As Integer
Dim lastRow1 As Integer, lastRow2 As Integer
On Error GoTo 0
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row 'last used cell in column A
lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row 'last used cell in column A
Dim same As Boolean
same = False
For i = lastRow1 To 2 Step -1 'bottom to top
For j = 2 To lastRow2
Debug.Print ws1.Cells(i, 1).Value
Debug.Print ws2.Cells(j, 1).Value
If ws1.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
same = True 'set True if match
End If
End If
Next j
If same = False Then 'if no match
Rows(i).EntireRow.Delete
End If
same = False
Next i
'sort
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lastRow1).Sort key1:=Range("A2:A" & lastRow1), order1:=xlAscending, Header:=xlNo, key2:=Range("B2:B" & lastRow1), order2:=xlAscending, Header:=xlNo
End Sub
Still thinking about the rest of the answer, but in advance I would advise you to start at the bottom of the list (so from lastrow to the second row) The reason for this is that you are removing rows which your counter does not take into account. You may also want to look into the MATCH function in Excel to see if a certain value is used in a list instead of going through the whole list.
So I have the script below in Execl VB that goes through the rows and deletes the ones that don't contain a certain keyword.
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
For i = 2 to ActiveSheet.UsedRange.Rows.Count
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
i = i - 1
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
End Sub
The problem is that this script takes a very long time to execute (around 8 minutes for ~73000 entries). Why is that and how would I go about improving it?
no offense to other answer, but this will only help with troubleshooting.
what you need to do is remove the the line of code
Rows(i).Delete
inside the (potentially) long running For loop is what is causing the slow down.
you need to re-write it like this...
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
Dim rng As Excel.Range
Dim arr() As Variant
Dim str As String
arr = ActiveSheet.UsedRange
Dim R As Long
For R = 1 To UBound(arr, 1) ' First array dimension is rows.
If InStr(arr(R, 1), Keyword) = 0 Then
If str <> "" Then
str = "," & str
End If
str = str & arr(R, 1).Address
End If
Next R
Set rng = ActiveSheet.Range(str)
RowsDeleted = rng.Rows.Count
rng.Delete
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
It takes ages may due to formulas in your cells that are going to be deleted.
What you should do is to turn off auto calculation and Clear the contents of that row before delete. Also you should start from bottom up!
Try this:
Sub Main()
Dim lMode As Long
' Store initial state of Calculation mode
lMode = Application.Calculation
' Change to Manual Calculation
Application.Calculation = xlCalculationManual
' Disable screen update
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
' Start from bottom up!
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).ClearContents
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
End If
Next i
' Restore screenupdate and calculation mode
Application.ScreenUpdating = True
Application.Calculation = lMode
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
Here could be something to look at,
It filters Column A for cells <>"Cola" and clears them
It then sorts column A so the blank cells in column A are now at the bottom
It then deletes the blank rows.
Not knowing the setup of the OP's ws, there may have to be adjustments made.
On my sample sheet I use 81,000 rows, when I run the code it takes about 5 seconds.
Sub SomeDeleteCode()
Dim Rws As Long, Rng As Range, nwRw As Long
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = 0
Application.Calculation = xlCalculateManual
Columns("A:A").AutoFilter Field:=1, Criteria1:="<>*Cola*"
Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
Rng.ClearContents
ActiveSheet.AutoFilterMode = 0
Columns(1).Sort Key1:=Range("A1"), Header:=xlYes
nwRw = Cells(Rows.Count, "A").End(xlUp).Row
Range(Range("B" & nwRw + 1), Range("B" & nwRw + 1).End(xlDown)).EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
End Sub
Amend your code to look like this:
Sub Main()
On Error Goto ErrHandler
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
For i = ActiveSheet.UsedRange.Rows.Count to 2
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
' i = i - 1 ' -- manually changing the loop counter is a bad idea
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
EndSub:
Application.ScreenUpdating = True
exit sub
ErrHandler:
' Error handling here
resume EndSub
End Sub
The error handler is required to ensure that the ScreenUpdating is restored, even in case of an error.
I have 2 workbooks that contain the same macro. In one workbook the macro runs super fast, less than a second. In the other it takes almost 30 seconds to run. I'm using Excel 2003. The page breaks are off in both workbooks. I don't know what could be causing one to run slower than the other. Any ideas?
Sub viewFirst()
Dim dataSheet As Worksheet, inputSheet As Worksheet, projectID As Long
Dim projectRow As Long, lLastRec As Long, inputLastRow As Long, dataLastRow As Long, x As Long, sh As Shape
Worksheets("Input").Select
ActiveSheet.Protect "", UserInterfaceOnly:=True
Range("a1").Select
ActiveSheet.Pictures.Insert ("working.jpg")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set inputSheet = Worksheets("Input")
Set dataSheet = Worksheets("Database")
With inputSheet
inputLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
End With
With dataSheet
dataLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
lLastRec = dataLastRow - 1
End With
With inputSheet
.Range("currentProject").Value = 1
projectID = .Range("currentProject").Value
projectRow = projectID + 1
For x = 1 To inputLastRow
If Range("b" & x).HasFormula Then
x = x + 1
End If
If x > inputLastRow Then
Exit For
End If
If Not Range("b" & x).HasFormula Then
.Range("b" & x).Value = dataSheet.Cells(projectRow, 2 + x)
End If
Next x
.Range("d125").Value = dataSheet.Cells(projectRow, 2 + 149)
.Range("d128").Value = dataSheet.Cells(projectRow, 2 + 150)
.Range("d131").Value = dataSheet.Cells(projectRow, 2 + 151)
.Range("d134").Value = dataSheet.Cells(projectRow, 2 + 152)
.Range("d137").Value = dataSheet.Cells(projectRow, 2 + 153)
.Range("d140").Value = dataSheet.Cells(projectRow, 2 + 154)
End With
With ActiveSheet
For Each sh In .Shapes
If sh.Type = msoPicture Then
ActiveSheet.Unprotect ""
sh.Delete
ActiveSheet.Protect "", UserInterfaceOnly:=True
End If
Next sh
End With
Range("b5").Select
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
-EDIT-
osknows, thanks for the response. Just to clarify, the workbooks are never open at the same time, and again the workbooks are identical except for the data on the dataSheet - the dataSheet where the macro runs slowly has 35 Rows x 204 Columns, the dataSheet that runs quickly has 56 Rows X 156 Columns. I am going to search for hidden columns or non-blank cells on the input sheet.
Without seeing the 2 workbooks it's difficult to tell. The best advice is to measure exactly the speed of your code by...
In a module decare
Public Declare Function GetTickCount Lib "kernel32" () As Long
then in your code between certain lines of code place
dtStart = GetTickCount
dtline2 = GetTickCount
dtline3 = GetTickCount
dtline4 = GetTickCount
..
etc
the number of ticks between dtStart and dtline2 equals dtline2 - stStart etc
Also a number of factors that could slow things down:
inputLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
could include many rows that seem blank but aren't.
Set inputSheet = Worksheets("Input") & Set dataSheet = Worksheets("Database") may be massive complex ranges
For Each sh In .Shapes could include many duplicate shapes over each other that look identical
You have undefined ranges & sheets that if you have multiple workbooks open and using them while code runs then workbooks/worksheets/ranges are not explicitly defined. (Eg .Range versus Range) Get into the habit of using the full path to a range Filepath/Workbook/Sheet/Range or cell etc using With statements
eg
With ThisWorkbook
With SheetXYZ
With .range("XYZ1")
End with
End With
End With
or
With ThisWorkbook
With SheetXYZ.range("XYZ1")
.formula = "=Now()"
End With
End With
Also check out this handy site Excel Pages
On the slower machine, unload any Add-ins. If you have an add-in with a global change event, that will fire every time any worksheet changes, and could be causing the slow down. You're writing to the spreadsheet quite a bit, so it would be called a lot.
Instead of writing cell-by-cell, consider building an array (2-dimensions, lower bound of 1) and write all the data to the cell in one big swoop. Here's an example of how that works
Sub WriteOnce()
Dim aReturn() As Double
Dim i As Long, j As Long
Const lLASTROW As Long = 10
Const lLASTCOL As Long = 5
ReDim aReturn(1 To lLASTROW, 1 To lLASTCOL)
For i = 1 To lLASTROW
For j = 1 To lLASTCOL
aReturn(i, j) = Rnd
Next j
Next i
Sheet1.Range("A1").Resize(UBound(aReturn, 1), UBound(aReturn, 2)).Value = aReturn
End Sub
Since I'm only accessing the worksheet once, any event handlers will only fire once.