excel fill formula till last row - excel

I have below vba code to put a formula in cell AE3 then copy down to last row, i have 5000+ rows but wonder why it take so long to process (about 5 min. and still running), is there a better way to do this? i want copy down to last row as the list is dynamic data with different ranges every day. Thanks.
Sub FillRows()
Dim col_AE As String
Sheet1.Select
col_AE = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
If col_AE <> vbNullString Then
For j = 3 To Range("A" & Rows.Count).End(xlUp).Row - 1
If Range("ae" & j).Value = vbNullString Then
Range("ae" & j).Value = col_AE
End If
Next j
End If
End Sub

You should turn off both ScreenUpdating and Calculations when working with large numbers of formulas.
This line If col_AE <> vbNullString Then isn't doing anything.
Option Explicit
Sub FillRows()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim col_AE As String
With Sheet1
For j = 3 To .Range("A" & .Rows.Count).End(xlUp).Row - 1
If .Range("ae" & j).Value = vbNullString Then
.Range("ae" & j).FormulaR1C1 = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
End If
Next j
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The majority of the processing time is being used because the sheet is recalculating every time a formula is added. I would just turn off ScreenUpdating and Calculations and replace all the formulas. In this way I know that the formulas are consistent and that any errors introduced by users would be corrected.
Sub FillRows2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim col_AE As String
With Sheet1
.Range("A3", "A" & .Rows.Count).End(xlUp).FormulaR1C1 = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

This might speed it up - turn off the screen updating while it is running.
Application.ScreenUpdating = False
Application.ScreenUpdating = True

Please try this:
Option Explicit
Sub fillFormula()
Dim wbk1 As Workbook
Dim lastRow As Long
Set wbk1 = ActiveWorkbook
With wbk1.Sheets("sheet1")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastRow = lastRow - 1
.Range("AE3:AE" & lastRow).Formula = _
"=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9]," _
& "setting!C[-18],0)),"""")"
End With
End Sub

Related

How to make code that deletes row if the date is older

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.

Insert a column then put a formula in the blank column 500 times

Here is the code that I am using
Sub insert_column_every_other()
Dim colx As Long
Dim H As Worksheet
Set H = Sheets("Sheet1") 'Replace H3 with the sheet that contains your data
For colx = 9 To 1200 Step 2
Call H.Columns(colx).Insert(Shift:=xlToRight)
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
Next colx
End Sub
Getting an error in the following line,
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
The error is Application-defined error.
The macro will create a column after the 9th column till the 500th column and then in the blank column will calculate the percentage difference of the stock price of two consecutive days so that's why I went with that particular offset formula.
I think this is what you are looking for
Option Explicit
Sub insert_column_every_other()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 9 To 1200 Step 2
ws.Columns(i).Insert
ws.Range(ws.Cells(2, i), ws.Cells(21, i)).Formula = "=(" & ws.Cells(2, i - 1).Address(False, False) & "-" & ws.Cells(2, i - 2).Address(False, False) & ")/(" & ws.Cells(2, i - 2).Address(False, False) & ")*SQRT(252)"
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Get Information from RemoveDuplicates

I have a short list of values in column K. If I use the Ribbon commands to remove duplicates, Excel removes the duplicates and outputs a message giving the number of duplicates removed:
If I use VBA to do the same thing:
Sub Macro1()
Columns("K:K").Cells.RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
The duplicates are removed, but the message never appears.
How do I get the message to appear if I use the macro ??
MsgBox doesn't allow a lot of room for customization, but setting up a UserForm to look exactly like the Remove Duplicates dialogue would be something you'd have to do on your end, so MsgBox will have to do.
Option Explicit
Sub RemoveDuplicatesWithReport()
Dim unique() As Variant
Dim ws As Worksheet
Dim x As Long, uidCt As Long, dCol As Long, remCt As Long
On Error GoTo ErrorHandler
'turn off screenupdating/calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'current sheet
Set ws = ActiveSheet
'column K
dCol = 11
'resize array for counting uniques
ReDim unique(ws.Cells(ws.Rows.Count, dCol).End(xlUp).Row)
'count how many unique values there are (uidCt)
For x = 2 To ws.Cells(ws.Rows.Count, dCol).End(xlUp).Row
If CountIfArray(ws.Cells(x, dCol), unique()) = 0 Then
unique(uidCt) = ws.Cells(x, dCol).Text
uidCt = uidCt + 1
End If
Next x
'count before removal
remCt = WorksheetFunction.CountA(ws.Columns(dCol)) - 1
'remove duplicates
ws.Columns(dCol).RemoveDuplicates Columns:=1, Header:=xlYes
'count after removal
remCt = remCt - (WorksheetFunction.CountA(ws.Columns(dCol)) - 1)
'turn screenupdating/calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
ws.Calculate
'display results
MsgBox remCt & " duplicate values were found and removed." & vbCr & uidCt & " unique values remain.", vbInformation, "Remove Duplicates"
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox Err.Number & vbCr & Err.Description
Exit Sub
End Sub
Public Function CountIfArray(lookup_value, lookup_array)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function

macro causing excel sheet to show segregated lines? How to get rid?

I am running this macro:
Sub Check()
ActiveSheet.EnableCalculation = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
If Sheets(1).Range("A1").Value = "Enter Data" Then
Sheets(2).Activate
Else
If Sheets(1).Range("H10").Value <> "" And Sheets(1).Range("I10").Value <> "" And Sheets(1).Range("J10").Value <> "" Then
Dim lastRow As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set sht1 = Sheets(2)
If sht1.Range("A1").Value <> "" Then
'insert column b formula
lastRow = sht1.Range("A" & Rows.Count).End(xlUp).Row
sht1.Range("B2").Formula = "=MID(A2, 1, 12)"
sht1.Range("B2").AutoFill Destination:=sht1.Range("B2:B" & lastRow)
'insert column c formula
sht1.Range("C2").Formula = "=--LEFT(B2,4)"
sht1.Range("C2").AutoFill Destination:=sht1.Range("C2:C" & lastRow)
'insert column d formula
sht1.Range("D2").Formula = "=--RIGHT(MID(A2, 14, 7),LEN(MID(A2, 14, 7))-FIND(LEFT(SUBSTITUTE(MID(A2, 14, 7)&"" "",""0"",""""),1),MID(A2, 14, 7)&"" "")+1)"
sht1.Range("D2").AutoFill Destination:=sht1.Range("D2:D" & lastRow)
'insert column E formula
sht1.Range("E2").Formula = "=DATE(""20""&MID(B2,9,2),MID(B2,7,2),MID(B2,5,2))"
sht1.Range("E2").AutoFill Destination:=sht1.Range("E2:E" & lastRow)
'insert column F formula
sht1.Range("F2").Formula = "=IF(E2<>"""",WEEKNUM(E2,21),"""")"
sht1.Range("F2").AutoFill Destination:=sht1.Range("F2:F" & lastRow)
'insert column G formula
sht1.Range("G2").Formula = "=SUBSTITUTE(TRIM(MID(A2, FIND(""-"", A2, FIND(""-"", A2)+9)+9,256)),"" "","" / "")"
sht1.Range("G2").AutoFill Destination:=sht1.Range("G2:G" & lastRow)
Else
MsgBox "Please First Copy and Paste Estimated Receivings."
End If
Set sht2 = Sheets(1)
With sht2
If Range("H10").Value <> "" Then
lastRow = .Cells(.Rows.Count, 10).End(xlUp).Row
.Range("K10").FormulaArray = "=IFERROR(INDEX(Data!$G:$G,MATCH(1,(Home!$H10=Data!$C:$C)*(Home!$I10=Data!$D:$D)*(IF(Home!$J10<55,Home!$J10,WEEKNUM(Home!$J10,21))=Data!$F:$F),0)),"""")"
If lastRow <> 10 Then
.Range("K10").AutoFill ActiveSheet.Range("K10:K" & lastRow)
End If
.Range("M10").FormulaArray = "=IFERROR(INDEX(Data!$B:$B,MATCH(1,(Home!$H10=Data!$C:$C)*(Home!$I10=Data!$D:$D)*(IF(Home!$J10<55,Home!$J10,WEEKNUM(Home!$J10,21))=Data!$F:$F),0)),""No Po Found"")"
If lastRow <> 10 Then
.Range("M10").AutoFill ActiveSheet.Range("M10:M" & lastRow)
End If
.Range("L10").FormulaArray = "=IFERROR(INDEX(Data!$F:$F,MATCH(1,(Home!$H10=Data!$C:$C)*(Home!$I10=Data!$D:$D)*(IF(Home!$J10<55,Home!$J10,WEEKNUM(Home!$J10,21))=Data!$F:$F),0)),"""")"
If lastRow <> 10 Then
.Range("L10").AutoFill ActiveSheet.Range("L10:L" & lastRow)
End If
Else
MsgBox "Please enter some data."
End If
End With
Else
MsgBox "At Least One Order Must Be Checked."
End If
End If
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
ActiveSheet.EnableCalculation = True
End Sub
For some reason, when the code has finished running, my excel sheet displays three segregated lines like this:
Why is this, and how can i remove them? I appreciate any help. Thanks
I think you should remove
ActiveSheet.DisplayPageBreaks = True

Delete rows with VB after background query has run - Excel 2010

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

Resources