I have a loop that is deleting rows based on the month within the date
Dim k As Long
For k = FindLastRow(.Sheets(NewSheet)) To 2 Step -1
If Not Month(.Sheets(NewSheet).Cells(k, 1).Value) = NewMonth Then
.Sheets(NewSheet).Rows(k).EntireRow.Delete
End If
Next k
This is very slow and I have code that I've used elsewhere for doing this quicker, this example is based on deleting 0 values:
Dim rngDataBlock As Range
Set rngDataBlock = .Range(.Cells(1, 1), .Cells(8, 8))
With rngDataBlock
.AutoFilter Field:=1, Criteria1:=0
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Delete
End With
.AutoFilterMode = False
What I can't figure out is how to apply this to my 1st case where I'm deleting based on the month of the date. I tried:
.AutoFilter Field:=1, Criteria1:="<>" & Month(NewMonth)
but this doesn't work, I guess as the filter is actually loking at whole dates rather than months. Can anyone help?
You can use the second criteria and operator parameters to delete using autofilter.
Dim rngDataBlock As Range
Set rngDataBlock = .Range(.Cells(1, 1), .Cells(16, 2))
With rngDataBlock
.AutoFilter Field:=2, Criteria1:=">=" & DateSerial(2021, Month(newmonth), 1), _
Operator:=xlAnd, Criteria2:="<=" & DateSerial(2021, Month(newmonth) + 1, -1)
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Delete
End With
.AutoFilterMode = False
You can also speed up your original example by unionizing the rows you want to delete and then deleting in one go.
Dim k As Long
Dim delrng As Range
For k = FindLastRow(.Sheets(NewSheet)) To 2 Step -1
If Not Month(.Sheets(NewSheet).Cells(k, 1).Value) = newmonth Then
If delrng Is Nothing Then
Set delrng = .Sheets(NewSheet).Rows(k).EntireRow
Else
Set delrng = Union(delrng, .Sheets(NewSheet).Rows(k).EntireRow)
End If
End If
Next k
delrng.Delete
Related
The below code is not deleting the rows as expected. Can someone tell me what is wrong with it?
With Worksheets("Alerts Ack By Cops")
For rw = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
Select Case UCase(.Cells(rw, "A").Value2)
Case "Punna,", "Juleas,"
.Rows(rw).EntireRow.Delete
i = i - 1
End Select
Next rw
End With
When you are looking for text with capital letter using UCase then you need to match with upper case values.
Change
Case "Punna,", "Juleas,"
to
Case "PUNNA,", "JULEAS,"
Also since you want to match the cell which starts with those words, you can use LIKE as shown below
With Worksheets("Alerts Ack By Cops")
For rw = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If UCase(.Cells(rw, "A").Value2) Like "PUNNA,*" Or _
UCase(.Cells(rw, "A").Value2) Like "JULEAS,*" Then
.Rows(rw).EntireRow.Delete
End If
Next rw
End With
Also, using autofilter would be faster. You may want to see Delete row based on partial text. Here the cirteria becomes "=" & strSearch & "*" instead of "=*" & strSearch & "*"
If you still want to delete the rows using a loop then you may want to see Union way of doing it in Excel VBA - Delete empty rows which will increase the speed drastically over a large number of rows.
Delete Rows Using AutoFilter
The first solution illustrates the use of two criteria.
The second solution illustrates how to do the same with an array. Unfortunately AutoFilter can have only two criteria containing wild characters. If you add more, nothing will be filtered.
The third solution illustrates a workaround which allows more than two criteria containing wild characters.
The Code
Option Explicit
Sub deleteTwoCriteria()
Application.ScreenUpdating = False
With Worksheets("Alerts Ack By Cops")
.AutoFilterMode = False
With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
.AutoFilter _
Field:=1, _
Criteria1:="Punna,*", _
Operator:=xlOr, _
Criteria2:="Juleas,*"
With .Resize(.Rows.Count - 1).Offset(1)
On Error Resume Next
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
End With
End With
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Sub deleteArray()
Application.ScreenUpdating = False
With Worksheets("Alerts Ack By Cops")
.AutoFilterMode = False
With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
.AutoFilter _
Field:=1, _
Criteria1:=Array("Punna,*", "Juleas,*"), _
Operator:=xlFilterValues
With .Resize(.Rows.Count - 1).Offset(1)
On Error Resume Next
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
End With
End With
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Sub deleteList()
Const CriteriaList As String = "Punna,*|Juleas,*|R2*"
Dim Criteria() As String: Criteria = Split(CriteriaList, "|")
Application.ScreenUpdating = False
With Worksheets("Alerts Ack By Cops")
.AutoFilterMode = False
With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
If .Cells.Count > 1 Then
Dim Data As Variant: Data = .Value
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim i As Long
Dim n As Long
For i = 2 To UBound(Data, 1)
For n = 0 To UBound(Criteria)
If LCase(Data(i, 1)) Like LCase(Criteria(n)) Then
dict(Data(i, 1)) = Empty
Exit For
End If
Next n
Next i
If dict.Count > 0 Then
.AutoFilter _
Field:=1, _
Criteria1:=dict.Keys, _
Operator:=xlFilterValues
With .Resize(.Rows.Count - 1).Offset(1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.Worksheet.AutoFilterMode = False
End If
End If
End With
End With
Application.ScreenUpdating = True
End Sub
Its update to my prior question for which i missed to add point saying that column 3 Header data might start with space or at the end or any additional text in it hence we should try it with contains.
Count results should be shown in a new sheet for all filter entities like 3 (Index) 3(Level) AIUH (Entity Name) 3(Count) with additional column to the end of the table and rows will not be
I apologize for my bad etiquette and wasting experts time on this to work again.
Here is the previous code for reference:
Sub xferAscendingFiltered()
Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant
'fill this array with your 40-50 Header values
vFLTRs = Array("AIS", "BBS", "AIUH", _
"XXX", "YYY", "ZZZ")
With Worksheets("Sheet2")
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
'filter on all the values in the array
.AutoFilter Field:=3, Criteria1:=vFLTRs, Operator:=xlFilterValues
'walk through the visible rows
With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
'seed the rows to delete so Union can be used later
If rHDR.Row > 1 Then _
Set rDELs = rHDR
Do While rHDR.Row > 1
cnt = 0
'increase cnt by both visible and hidden cells
Do
cnt = cnt + 1
Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing
'transfer the values and clear the original(s)
With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
'transfer the values
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
'set teh count
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1 - cnt, 3) = cnt
Set rDELs = Union(rDELs, .Cells)
rHDR.Clear
End With
'get next visible Header in column C
Set rHDR = .FindNext(After:=.Cells(1, 1))
Loop
.AutoFilter
End With
End With
'remove the rows
rDELs.EntireRow.Delete
End With
End Sub
Prior question link:
Thanks experts
Wildcards in your filter code.
To use contains using a variable, this should work as the criteria to find:
This will loop through the array and place a 1 beside a match, then filter column D for 1
Sub xferAscendingFiltered()
Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant
'-------------
Dim rng As Range, cel As Range, LstRw As Long, sh As Worksheet, i '<<<<<
Set sh = Sheets("Sheet2") '<<<<<<<<
'---------------
'fill this array with your 40-50 Header values
vFLTRs = Array("AIUH", "ASC", "ABB", "BBS", "YYY", "ZZZ")
'vFLTRs = Array("*BBS*", "*ABB*", "*ASC*", "*AIUH*")
With sh
'-----------------------------------<<<<<<
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = Range("C2:C" & LstRw)
'----Loop Through Array-----
For i = LBound(vFLTRs) To UBound(vFLTRs)
For Each cel In rng.Cells
If cel Like "*" & vFLTRs(i) & "*" Then
cel.Offset(, 1) = 1
End If
Next cel
Next i
With .Cells(1, 1).CurrentRegion
'filter on all the values in the array
.AutoFilter Field:=4, Criteria1:=1
'-----------------------------------<<<<<<<<<
'walk through the visible rows
With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlNext)
'seed the rows to delete so Union can be used later
If rHDR.Row > 1 Then Set rDELs = rHDR
Do While rHDR.Row > 1
cnt = 0
'increase cnt by both visible and hidden cells
Do
cnt = cnt + 1
Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing
'transfer the values and clear the original(s)
With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
Set rDELs = Union(rDELs, .Cells)
rHDR.Clear
End With
'get next visible Header in column C
Set rHDR = .FindNext(After:=.Cells(1, 1))
Loop
.AutoFilter
End With
End With
'remove the rows
rDELs.EntireRow.DELETE
End With
End Sub
I'm using AutoFilter to delete some rows before a different macro is run. One of my filters brings up some notes that I need to save for later pasting. I assume saving it to a variable will allow me to then delete those rows and paste them when needed later. Here's what I have so far:
Sub Test()
With Sheet1
.AutoFilterMode = False
With Range("A10", Range("A" & Rows.Count).End(xlUp))
On Error Resume Next
.AUTOFILTER Field:=1, Criteria1:="=(**", Operator:=xlFilterValues
'Insert code to copy values to variable here
.Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub
I can't figure out how to copy the visible cells to a variable. Tried using xlCellTypeVisible but it didn't work.
So I figured it out. Here's the code below
With Sheet1
.AutoFilterMode = False
With Range("A10", Range("A" & Rows.Count).End(xlUp))
On Error Resume Next
.AUTOFILTER Field:=1, Criteria1:="=Device*", Operator:=xlFilterValues
.Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).EntireRow.delete
.AUTOFILTER Field:=1, Criteria1:="=Manufacturer", Operator:=xlFilterValues
.Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).EntireRow.delete
.AUTOFILTER Field:=1, Criteria1:="=(**", Operator:=xlFilterValues
Set MyRange = Sheet1.Range("A10: I" & Cells(Rows.Count - 1, 1).End(xlUp).Row).Offset(1, 0).SpecialCells(xlCellTypeVisible)
CalVal = MyRange
.Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).EntireRow.delete
End With
.AutoFilterMode = False
End With
This deletes the rows I needed deleted while saving the ones that start with "(".
Later I paste it on sheet 2 after everything else has been copied.
'Paste Notes
NumRows = UBound(CalVal, 1) - LBound(CalVal, 1) + 1
NumCols = UBound(CalVal, 2) - LBound(CalVal, 2) + 1
Set Destination = ws2.Range("A" & lastRow).Offset(1, 0)
Destination.Value = "Table Notes"
Destination.Font.Bold = True
Set Destination = ws2.Range("A" & lastRow).Resize(NumRows, NumCols).Offset(2, 0)
Destination = CalVal
Need to Dim MyRange, CalVal, LastRow, NumRows, and NumCols of course
I have this code. It loops through a list for the filtering criteria, then if no data to select it shows all data again and loops to the next criteria. If it shows data it end(slDown) and selects all the data showing, copies it and pastes it into another worksheet.
The cleanup script cleans any blank rows and columns and then returns to the original data sheet and deletes the data selected for the copy paste.
The problem is when there is just one row. It moves to the row with data, but when I End(xlDown), it shoots all the way to the bottom and the paste then causes the macro to freeze up.
I nested another if statement to capture if there is only one line of data visible, but I cannot get it to function correctly. Any Suggestions on the nested if statement?
Dim criteria As String
Dim F As Range
Set Rng = Sheets("Reference").Range("W2:W36")
For Each F In Rng
criteria = F
ActiveSheet.Range("$AV$1").AutoFilter Field:=48, Criteria1:="=*BULK SUBSERVIENT*", Operator:=xlAnd
ActiveSheet.Range("$K$1").AutoFilter Field:=11, Criteria1:=criteria
Range("A2:CM" & ActiveSheet.UsedRange.Rows.Count + 1) _
.Cells.SpecialCells(xlCellTypeVisible).Rows(1).Select
If ActiveCell.Value = vbNullString Then
ActiveSheet.ShowAllData
Else
If (ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell)) = 2 Then
'Range(Selection).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
Else
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
End If
End If
Next F
I figured it out.... Here is what I did. Thanks all!
I used this If ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas.Count <= 2
instead of this (ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell)) = 2
Dim criteria As String
Dim F As Range
Set Rng = Sheets("Reference").Range("W2:W36")
For Each F In Rng
criteria = F
ActiveSheet.Range("$AV$1").AutoFilter Field:=48, Criteria1:="=*BULK SUBSERVIENT*", Operator:=xlAnd
ActiveSheet.Range("$K$1").AutoFilter Field:=11, Criteria1:=criteria
Range("A2:CM" & ActiveSheet.UsedRange.Rows.Count + 1) _
.Cells.SpecialCells(xlCellTypeVisible).Rows(1).Select
If ActiveCell.Value = vbNullString Then
ActiveSheet.ShowAllData
Else
If ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas.Count <= 2 Then
'Range(Selection).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
Else
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
End If
End If
Next F
I think your code could be much cleaner than this. I prefer to use an auxiliar funcion to make this filter. Something like this:
Function MyFilter(criteria as string) as Range
Set tableRange = ActiveSheet.UsedRange
' Filter
With tableRange
Call .AutoFilter(48, "*BULK SUBSERVIENT*")
Call .AutoFilter(11, criteria)
End With
On Error Resume Next
'This...
Set selectedRange = tableRange.SpecialCells(xlCellTypeVisible)
'...Or (how to remover title).
Set selectedRange = Intersect(tableRange.SpecialCells(xlCellTypeVisible), .[2:1000000])
On Error GoTo 0
With tableRange
Call .AutoFilter(11)
Call .AutoFilter(48)
End With
'Empty Criteria
If WorksheetFunction.CountA(selectedRange) < 2 Then
Exit Sub
End If
Set MyFilter = selectedRange
End Sub
Here is your original code rewritten using the Range.CurrentRegion property to define the range of cells to be filtered.
Dim criteria As String
Dim F As Range, rng As Range
With Worksheets("Reference")
Set rng = .Range(.Cells(2, 23), .Cells(Rows.Count, 23).End(xlUp))
End With
With ActiveSheet '<~~ set this to worksheets("Sheet1") as appropriate
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
For Each F In rng
criteria = F
.AutoFilter Field:=48, Criteria1:="*BULK SUBSERVIENT*"
.AutoFilter Field:=11, Criteria1:=criteria
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Copy Destination:=Sheets("Bulk Subservient").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
End With
Next F
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
Here is the same thing that collects all of the criteria terms from the Reference worksheet into a variant array and uses that to filter for all terms at once.
Dim rng As Range
Dim vCRITERIA As Variant, v As Long
With Worksheets("Reference")
ReDim vCRITERIA(1 To 1) '<~~for alternate method
For Each rng In .Range(.Cells(2, 23), .Cells(Rows.Count, 23).End(xlUp))
vCRITERIA(UBound(vCRITERIA)) = rng.Value2
ReDim Preserve vCRITERIA(UBound(vCRITERIA) + 1)
Next rng
ReDim Preserve vCRITERIA(UBound(vCRITERIA) - 1)
End With
With ActiveSheet '<~~ set this to worksheets("Sheet1") as appropriate
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.AutoFilter Field:=48, Criteria1:="*BULK SUBSERVIENT*"
.AutoFilter Field:=11, Criteria1:=(vCRITERIA), Operator:=xlFilterValues
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Copy Destination:=Sheets("Bulk Subservient").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
The latter is likely a few milli-seconds faster than the first.
The worksheet's SUBTOTAL function never includes filtered or hidden rows so asking for a count will determine if there is anything to copy. Resizing and offsetting moves to the filtered range.
You will need to reincorporate the Cleanup subroutine.
what i am trying to do.
I have two worksheets "dashboard" and "temp calc".I am trying to delete rows based on two different conditions in each worksheet.
Dashboard- delete rows if column number 15 <> active
delete rows if column number 10 <> E&D,ESG,PLM SER,VPD,PLM Prod.
Temp calc = Delete rows if column number 6 is blank
delete rows if column number 3n1
where n1 and n2 are dates taken from range("n1" and "n2") in dashboard.
What I have tried.
using a for loop
using a filter
arrays(I am unable to actually do this using an array
My Problem
these methods are very slow and my data is around 1,68,000(grows on a weekly basis).So I am looking for alternatives to what I have tried. Basically something which will do this fast.
my codes I have tried.
the below code works but it takes upto 6-10 minutes depending on the data
Worksheets("Dashboard").Activate
Range("A4").Select
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For x = lastrow To 4 Step -1
If Cells(x, 15).Value <> "Active" Or (Cells(x, 10).Value <> "E&D" And Cells(x, 10).Value <> "ESG" _
And Cells(x, 10).Value <> "PLM SER" And Cells(x, 10).Value <> "VPD" And Cells(x, 10).Value <> "PLM PROD") Then
Rows(x).Delete
End If
Next x
The below code uses the autofilter method.the problem is that data which is not in my compare range is left after filtering(i.e if my n1 =1st Jan and n2=30th jan 2013. the filter will still leave behind data that is not in the n1 and n2 range.
Set ws = ThisWorkbook.Worksheets("Temp Calc")
'~~> Start Date and End Date
Sheets("Dashboard").Select
N1 = Range("n1").Value
N2 = Range("n2").Value
Sheets("Temp Calc").Select
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Get the last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Identify your data range
Set FltrRng = .Range("A1:F" & lRow)
'~~> Filter the data as per your criteria
With FltrRng
'~~> First filter on blanks
.AutoFilter Field:=6, Criteria1:="="
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'~~> Delete the filtered blank rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
ws.ShowAllData
'~~> Next filter on Start Date
.AutoFilter Field:=3, Criteria1:="<" & N1, Operator:=xlAnd
'~~> Finally filter on End Date
.AutoFilter Field:=4, Criteria1:=">" & N2, Operator:=xlAnd
'~~> Filter on col 6 for CNF
'.AutoFilter Field:=6, Criteria1:="CNF"
'~~> Delete the filtered rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'~~> Remove any filters
.AutoFilterMode = False
End With
Apologies in case the question is not adequate.
Any alternatives which will speed up what I am trying to do is highly appreciated.
Auto filter is fast - definitely the way to go - but it hides data rows and doesn't delete them. Since your code turns the filter off at the end, the hidden rows come back. Instead, you should apply the filter, select all, copy, paste into new sheet, and delete the old sheet. This will be very fast - and do exactly what you are asking for.
Apologies that I am not posting working code - typing on ipad...
Try below code
Sub DeleteRows()
Dim x As Long
Dim Rng As Range
Dim lastRow As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheets("Dashboard")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A1:A" & lastRow)
For x = Rng.Rows.Count To 1 Step -1
If .Cells(x, 15).Value <> "Active" Or (.Cells(x, 10).Value <> "E&D" And .Cells(x, 10).Value <> "ESG" _
And .Cells(x, 10).Value <> "PLM SER" And .Cells(x, 10).Value <> "VPD" And .Cells(x, 10).Value <> "PLM PROD") Then
Rng.Rows(x).Delete
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub