Elliottj2121
Board Regular
- Joined
- Apr 15, 2021
- Messages
- 50
- Office Version
- 365
- 2019
- Platform
- Windows
Hello All! I received some fantastic help from a previous post about creating a formula. See post here. However, I wanted to make things a little more automated so I used the formula in a macro along with some other formatting and filter etc. However, the macro runs really slow. I know enough to get me into trouble. To analogize it to reading, I think I'm still in the elementary school. Is there someone that can help me rewrite it so runs a little faster? The number of rows varies but typically in the twenty thousand range.
VBA Code:
Sub SKIPS()
Dim lr As Long, r As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets(1)
lr = LastRow(ws)
lr = Cells.Find("*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set Rng = Range("A2:A" & lr)
Set rng2 = Range("H2:H" & lr)
Application.ScreenUpdating = False
'Range("H1").FormulaR1C1 = "Skipped"
With ws
Range("L1").FormulaR1C1 = "1"
Range("L1").NumberFormat = "0"
Range("L1").Copy
Range("A1").CurrentRegion.PasteSpecial xlPasteAll, xlPasteSpecialOperationMultiply, False, False
Columns(4).NumberFormat = "m/d/yyyy"
Columns(5).Style = "Currency"
Rows("1:1").WrapText = True
Rows("1:1").Font.Bold = True
Columns("A:G").HorizontalAlignment = xlCenter
Columns("A:G").VerticalAlignment = xlCenter
Range("H1").Value = "Skipped = 1"
End With
For Each Cell In Rng
If Cell.Value <> "" Then
Cell.Offset(0, 7).FormulaR1C1 = "=IF(RC[-2]=""NULL"",IF(COUNTIFS(R2C[-6]:R50000C[-6],RC[-6],R2C[-4]:R50000C[-4],"">=""&RC[-4],R2C[-1]:R50000C[-1],1),1,0),0)"
End If
Next
'For r = rng2.Cells.Count To 1 Step -1
'With rng2.Cells(r)
'If .Value = 0 Then
'.EntireRow.Delete
'End If
'End With
'Next r
'Range("A1").Select
'Selection.CurrentRegion.AutoFilter Field:=8, Criterial:="1"
Columns("A:H").ColumnWidth = 16
With Range("H1:H" & lr)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Range("H1:H" & lr)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:H").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=5, Criteria1:=">0"
ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=7, Criteria1:="-1"
ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=8, Criteria1:="1"
Application.ScreenUpdating = True
End Sub
Function LastRow(sh As Worksheet) As Variant
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
LookAt:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End Function
Good to hear!
