all!
I would need to go through over 50k rows of data and delete rows with useless information.
The current code works but is, unfortunately, all to slow... I tried understanding how it could be made more efficient but there wasn't easily found any concrete examples that I could have understood.
Here is the current code:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ThisWorkbook.Worksheets("FIC DATA WITH 3A").Activate
vika = Cells(Rows.Count, "B").End(xlUp).Row
r = 2
For i = 2 To vika
If Not Cells(r, "J") > 42369 Then
Rows(r).EntireRow.Delete
ElseIf Cells(r, "I") = "OC" Or Cells(r, "B") = "Sales Doc." Or Cells(r, "B") = "" Then
Rows(r).EntireRow.Delete
Else
r = r + 1
End If
Next i
Could you maybe help? Concrete examples are more than appreciated.
In order to delete rows, you need to loop backwards For i = vika To 2 Step -1.
Also, there's no need to Activate "FIC DATA WITH 3A" sheet, in order to run the code on it.
The correct syntax to delete a row is Rows(i).Delete , and not Rows(r).EntireRow.Delete. If you want to use EntireRow, then the syntax is Range("A" & i).EntireRow.Delete (but doesn't make any sense to me why use it in this situation).
Code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Worksheets("FIC DATA WITH 3A")
vika = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = vika To 2 Step -1
If Not Cells(i, "J") > 42369 Or Cells(i, "I") = "OC" Or Cells(i, "B") = "Sales Doc." Or Cells(i, "B") = "" Then
Rows(i).Delete
End If
Next i
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Shai Rado Answer about looping in reverse order is very important.
To speed up your code you need to convert Excel data into arrays rather than referring Cells in every loop iteration - it runs way faster.
Here is description how to achieve it:
Arrays And Ranges In VBA
In your case you would need 2 arrays, one for I and J columns, second for B column.
Related
For every ID on my database i have to sum all the concepts linked to them. For example ID 2354 has 3 concepts, each one on a different row, i have to sum the amount of the 3 concepts, paste that sum on the cell where the amount of the first of this concepts originally was, and then eliminate the entire row of the second and third concepts.
My macro already do this, but the running time is very high, and my database is huge, around 100,000 rows, i need a way to improve the running time. Here is the code i have:
Sub Macro1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim t As Long
Dim a As Integer
Dim i As Integer
lastt = Cells(Rows.Count, "A").End(xlUp).Row vacía
For i = 1 To 30
If Cells(1, i).Text = "Report Legacy Key" Then
For t = 2 To lastt
For a = 1 To 40
primera = Cells(t, i).Value
ultima = Cells(t + a, i).Value
repetidas = Range(Cells(t, i + 1), Cells(t + a, i + 1))
If primera = ultima Then
c = Application.WorksheetFunction.Sum(repetidas)
Cells(t, i + 1).Activate
ActiveCell.Value = c
Range(Cells(t + 1, "A"), Cells(t + a, "AB")).Select
Selection.Delete Shift:=xlUp
End If
Next a
If IsEmpty(Cells(t + 1, "A").Value) = True Then
Exit For
End If
Next t
End If
Next i
Application.ScreenUpdating = True
Range("M1").Select
Application.CutCopyMode = False
End Sub
This code allows to do the process for 1000 rows in about 15 seconds, which is very slow, considering it has to be done for around 100,000 rows.
You can do several things to improve execution time:
Instead of working with Cells, use arrays or, even better, Scripting.Dictionary. This option alone will speed up quite a lot.
Sometimes we tend to process data directly on the worksheet, but many basic operations can be done directly in SQL, like sums.
Try avoid redundand operations, like selecting a Range and then using the Selection. Do your operation directly on the Range.
For example you can change this:
Range(Cells(t + 1, "A"), Cells(t + a, "AB")).Select
Selection.Delete Shift:=xlUp
To this:
Range(Cells(t + 1, "A"), Cells(t + a, "AB")).Delete Shift:=xlUp
Following this suggestions should speed things up quite a lot.
Hope this helps.
Looking for some assistance programming a report. I'm in the early stages. I've hit a wall when attempting to conditionally subtract using VBA. I would like to Subtract 1 from Column C if Column B is greater than 1. Any assistance would be greatly appreciated. The code I have so far is below
Sub UniqueContactReport()
Columns("Z:AQ").EntireColumn.Delete
Columns("X").EntireColumn.Delete
Columns("V").EntireColumn.Delete
Columns("U").EntireColumn.Delete
Columns("J:S").EntireColumn.Delete
Columns("A:H").EntireColumn.Delete
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = N To 1 Step -1
If Cells(i, "B") > 1 And Cells(i, "D") = 0 Then
Cells(i, "B").EntireRow.Delete
End If
Next i
End Sub
To succinctly address your question:
Sub ModifyColumnC()
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row ' See comment below
For i = 1 to N 'no need to go backwards because you are not deleting
If Cells(i, "B").Value > 1 Then
Cells(i, "C").Value = Cells(i,"C").Value -1
End If
Next i
End Sub
I have added .Value simply because I try to avoid implicit code. But yes, .Value is the default behaviour. I have left the code that determines the end row because all the following rows are going to be blank (thus <1) and this saves processing time (potentially a lot of it).
An alternative piece of code to do exactly the same thing.
Sub ModifyColumnC()
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 to N
Cells(i, "C").Value = Cells(i,"C").Value - IIf(Cells(i, "B").Value > 1,1,0)
Next i
End Sub
A nuance is that in the IIf command, all paths are evaluated. But in this case, both the true and false statements are simple constants and unlikely to raise any exceptions.
From your question it seems this is what you want.
Sub UniqueContactReport()
Columns("Z:AQ").EntireColumn.Delete
Columns("X").EntireColumn.Delete
Columns("V").EntireColumn.Delete
Columns("U").EntireColumn.Delete
Columns("J:S").EntireColumn.Delete
Columns("A:H").EntireColumn.Delete
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = N To 1 Step -1
If Cells(i, "B") > 1 And Cells(i, "D") = 0 Then
debug.print Cells(i, "C").value - 1
End If
Next i
End Sub
you could make no loop and use AutoFilter():
Sub UniqueContactReport()
With Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row) 'reference column B cells from row 1 down to last not empty one
.AutoFilter field:=1, Criteria1:=">1" ' filter referenced range on their value being >1
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then ' if any filtered cell other then the header (first one)
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(, 1) ' reference filtered cells corresponding ones one colum to the right
.Value = .Value - 1 ' lower referenced cell value by one
End With
If .Cells(1, 1).Value > 1 Then .Cells(1, 2) = .cell(1, 2) - 1 ' check if first cell is to be treated, too (first cell of filtered range is assumed as the "header" so doesn't get caught in filter action)
End If
.Parent.AutoFilterMode = False ' remove autofilter
End With
End Sub
BTW you can collapse all those EntireColumn.Delete statements into one:
Range("Z1:AQ1,X1, V1, U1, J:S, A:H").EntireColumn.Delete
but in this case you have to properly adjust the columns reference in the list since columns get deleted in one shot i.e. what-you-list-is-what-gets-deleted while in your previous approach the order of the delete statements affects which original columns gets actually deleted
First I wish to check if the value in in each row of column D of "Sheet1" matches any row of column A of "Accepted". If there is a match, I would like to copy the value in column B of that row of "Sheet1" into column D of "Accepted".
However, as there are 2 possible values in column B of "Sheet1", I would like to split the values into two columns of "Accepted" - Columns D and E. Hence, the next loop, if the value in column D of "Accepted" is not "Restricted", then copy that value into Column E and remove content of Column D.
The code works fine in that it helps me to achieve my goal, however, the process is taking too long, and after some investigation I found out that the delay only occurs with the last loop. I was wondering if I could speed up this process, thanks!
Dim i As Long
Dim j As Long
Dim k As Long
'to speed up the VBA code
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
AcceptedLastRow = ActiveWorkbook.Worksheets("Accepted").Range("A" & Rows.Count).End(xlUp).Row
Sheet1LastRow = ActiveWorkbook.Worksheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row
For j = 1 To AcceptedLastRow
For i = 1 To Sheet1LastRow
If ActiveWorkbook.Worksheets("Sheet1").Cells(i, 4).Value = ActiveWorkbook.Worksheets("Accepted").Cells(j, 1).Value Then
ActiveWorkbook.Worksheets("Accepted").Cells(j, 4).Value = ActiveWorkbook.Worksheets("Sheet1").Cells(i, 2).Value
End If
Next i
Next j
'to transfer recognised status to the recognised column and to remove from restricted column
'I think this is the section which contributes to the lag/delay
Restrictedlastrow = ActiveWorkbook.Worksheets("Accepted").Range("D" & Rows.Count).End(xlUp).Row
For k = 9 To Restrictedlastrow
If ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Value <> "Restricted" Then
ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Copy ActiveWorkbook.Sheets("Accepted").Cells(k, 5)
ActiveWorkbook.Sheets("Accepted").Cells(k, 4).ClearContents
End If
Next k
'to reset settings back to normal
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Instead of
ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Copy ActiveWorkbook.Sheets("Accepted").Cells(k, 5)
Use
ActiveWorkbook.Sheets("Accepted").Cells(k, 5) = ActiveWorkbook.Sheets("Accepted").Cells(k, 4)
Copy is an expensive operation. Since you seem to be interested only in a value of a cell, assign it directly (like you did in the previous loops).
I am trying to create a conditional loop macro in Excel. Column B contains a last name, Column C contains a first name, and Column D contains a first and last name. I am trying to get the macro to detect when Column D = Column C + Column B.
If D = C + B, then clear contents of D.
So, the following works for a single row:
Sub ClearContentsD ()
If Range("D1").Value = Range("C1").Value + Space(1) + Range("B1") Then Range("D1").ClearContents
End Sub
It does not work without the added Space(1), and I cannot get it to loop through the whole worksheet:
Sub ClearContentsLoop()
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Rows.Count
Next i
Do While Cells(i, 4).Value = Cells(i, 3).Value + Space(1) + Cells(i, 2).Value
Cells(i, 4).ClearContents
Loop
Application.ScreenUpdating = True
End Sub
VBA doesn't like my Do While. Any help would be greatly appreciated.
CJ
Some issues:
You must concatenate strings with &. The plus (+) is for addition;
Your For loop is not doing anything: its body is empty;
Your Do While Loop will at most run once, because i is not incremented;
It is a mystery why you would want two loops (For and Do While);
A sheet has many rows of which you only use a fraction, so don't loop through all of them (For) and use UsedRange.
Possible correction:
Sub ClearContentsLoop()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 4).Value = Cells(i, 3).Value & " " & Cells(i, 2).Value Then
Cells(i, 4).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub
There is a way to ignore the space in the values you are evaluating. Try this:
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Rows.Count
If InStr(1, Cells(i, 4).Value, Cells(i, 2).Value, vbTextCompare) > 0 And InStr(1, Cells(i, 4).Value, Cells(i, 3).Value, vbTextCompare) > 0 Then Cells(i, 4).ClearContents
Next i
Application.ScreenUpdating = True
Explanation:
By using the InStr function, you are testing for the presence of one text string inside of another, and if at least one match is found, then the function returns a non-zero value (the position where the match was found). In the above example, you are testing for the presence of the first name and last name at the same time, and if both are found, then the code clears out the contents of the cell.
And, as was pointed out in the comments section, you need to do this inside the loop so that all cells down the length of the worksheet are evaluated and updated as specified.
Be sure to test this on a COPY of your original data so that you don't lose the original values in case you want to roll back your changes! ;)
This is my first post. I am new to VBA and programming in general. I am still trying to get the hang of when to use variables and everything else. I am writing a basic VBA against a download file that can not be changed. Code is below
Sub KPIMacroFull()
Set sht = ThisWorkbook.Worksheets(Sheet1.Name)
Rows("1:2").Select
Selection.Delete Shift:=xlUp
ActiveCell.Offset(0, 9).Activate
Range("J:J").AutoFilter 1, 20
lr = Cells(Rows.Count, "J").End(xlUp).Row
If lr > 1 Then
Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
Cells.AutoFilter
Cells.AutoFilter
ActiveCell.Offset(0, 0).Activate
ActiveCell.Offset(0, 20).Activate
Range("AD1").EntireColumn.Insert
Range("AD1").Value = "Rush or Regular"
Range("A1:AK1").Columns.AutoFit
Range("AC:AC").AutoFilter 29, "D"
So basically what I want to do is autofilter column AC for values "D","K","Q","V","U",1,9. then in Column AD excel would return "Regular". For all other values in column AC (there are about 15 more classifications) I want excel to return "Rush". I am thinking a variable to set Regular to the above values and then going from there, but I am lost.
I checked a lot of other autofilter and VBA posts, but my questions seems to be more rudimentary and have not found anything too helpful.
This sniplet is independent from your solution as that relies too much on views.
My sniplet parses through your "AC" column and does all your required fill-in.
It is time-consuming, but not as much as yours (I assume you're not working on 100,000 record datasets, more like couple-hundred line evaluations of MMOs so it really shouldn't matter).
Filtering itself is up to you, add that part to the end of my sub.
Sub ertdfgcvb()
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim RegBool As Boolean
Dim ert As String
Dim MyArray(6) As String
MyArray(0) = "D"
MyArray(1) = "K"
MyArray(2) = "Q"
MyArray(3) = "V"
MyArray(4) = "U"
MyArray(5) = "1"
MyArray(6) = "9"
For i = 1 To LastRow
RegBool = False
ert = CStr(Cells(i, 29).Value) 'the CStr is unnecessary
'unless you want to make it case-insensitive, in which case
'you'll want to wrap it in a UCase() function
For j = 0 To 6 'size of your array
If InStr(1, ert, MyArray(j)) <> 0 Then RegBool = True
Next
If RegBool Then
Cells(i, 30) = "Regular"
Else
Cells(i, 30) = "Rush"
End If
Next
End Sub