Improve VBA Code to Run Faster

bmkelly · Feb 17, 2022

Hello,

I have a pretty lengthy code that takes about 4-5 minutes to run and was wondering if there is any improvements that could be made to it to help cut the run time down some?

VBA Code:

Sub AscCSFormat()

Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False

'Select the correct worksheet and table then remove filters'
    Worksheets(15).Activate
    
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
        With Cells
            .EntireColumn.Hidden = False
            .EntireRow.Hidden = False
        End With

'Adjust column widths'
    Columns("E:E").ColumnWidth = 80
    Columns("F:F").ColumnWidth = 37
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").ColumnWidth = 60
    Columns("J:J").ColumnWidth = 60
    Columns("K:K").ColumnWidth = 108

    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[Description]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(15).ListObjects(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Dim oLo As ListObject, l As Long, note As String
    Set oLo = Worksheets(15).ListObjects(1)
        With oLo
    For l = 1 To .ListRows.Count

note = "Retired - No Coverage"
        If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If

note = "All Parts & Labor"
        If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If
        
        Next l

        End With
        
'Change Header to Proration Date'
    Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        
Dim LastColumn As Long

    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To LastColumn
    If UCase(Cells(1, i)) = "CEID" Or UCase(Cells(1, i)) = "SERIAL" Or UCase(Cells(1, i)) = "RETIRED DATE" Or UCase(Cells(1, i)) = "PRORATION DATE" Then Columns(i).Hidden = True
        Next
        
ActiveSheet.ResetAllPageBreaks

Dim hdr As Range, f As Range, r As Range
Dim cell As String
  
    Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)
        If Not hdr Is Nothing Then
    Set r = Columns(hdr.Column)
    Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
            cell = f.Address
        Do
            f.Offset(1).PageBreak = xlPageBreakManual
        Set f = r.FindNext(f)
        
      Loop While Not f Is Nothing And f.Address <> cell
      
    End If
    
  End If
     
Dim ws As Worksheet

Set ws15 = Worksheets(15)
Set oLo = ws15.ListObjects(1)

With oLo
    For i = 1 To .ListRows.Count
        If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
            If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                ws15.Rows(oLo.HeaderRowRange.Row + i).Hidden = True
            End If
        End If
    Next i
End With
        
'Select the correct worksheet and table then remove filters'
    Worksheets(16).Activate
    
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
        With Cells
            .EntireColumn.Hidden = False
            .EntireRow.Hidden = False
        End With
        
'Adjust column widths'
    Columns("E:E").ColumnWidth = 80
    Columns("F:F").ColumnWidth = 37
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").ColumnWidth = 60
    Columns("J:J").ColumnWidth = 60
    Columns("K:K").ColumnWidth = 108
    
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[Description]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(16).ListObjects(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Set oLo = Worksheets(16).ListObjects(1)
        With oLo
    For l = 1 To .ListRows.Count

note = "Retired - No Coverage"
        If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If

note = "All Parts & Labor"
        If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If
        
        Next l

        End With
        
'Change Header to Proration Date'
    Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To LastColumn
    If UCase(Cells(1, i)) = "CEID" Or UCase(Cells(1, i)) = "SERIAL" Or UCase(Cells(1, i)) = "RETIRED DATE" Or UCase(Cells(1, i)) = "PRORATION DATE" Then Columns(i).Hidden = True
        Next
        
ActiveSheet.ResetAllPageBreaks
 
    Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)
        If Not hdr Is Nothing Then
    Set r = Columns(hdr.Column)
    Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
            cell = f.Address
        Do
            f.Offset(1).PageBreak = xlPageBreakManual
        Set f = r.FindNext(f)
        
      Loop While Not f Is Nothing And f.Address <> cell
      
    End If
    
  End If
     
Dim ws16 As Worksheet

Set ws16 = Worksheets(16)
Set oLo = ws16.ListObjects(1)

With oLo
    For i = 1 To .ListRows.Count
        If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
            If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                ws16.Rows(oLo.HeaderRowRange.Row + i).Hidden = True
            End If
        End If
    Next i
End With
        
'Select the correct worksheet and table then remove filters'
    Worksheets(17).Activate
    
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
        With Cells
            .EntireColumn.Hidden = False
            .EntireRow.Hidden = False
        End With
        
'Adjust column widths'
    Columns("E:E").ColumnWidth = 80
    Columns("F:F").ColumnWidth = 37
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").ColumnWidth = 60
    Columns("J:J").ColumnWidth = 60
    Columns("K:K").ColumnWidth = 108
    
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[Description]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(17).ListObjects(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Set oLo = Worksheets(17).ListObjects(1)
        With oLo
    For l = 1 To .ListRows.Count

note = "Retired - No Coverage"
        If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If

note = "All Parts & Labor"
        If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If
        
        Next l

        End With
        
'Change Header to Proration Date'
    Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To LastColumn
    If UCase(Cells(1, i)) = "CEID" Or UCase(Cells(1, i)) = "SERIAL" Or UCase(Cells(1, i)) = "RETIRED DATE" Or UCase(Cells(1, i)) = "PRORATION DATE" Then Columns(i).Hidden = True
        Next
    
ActiveSheet.ResetAllPageBreaks
  
    Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)
        If Not hdr Is Nothing Then
    Set r = Columns(hdr.Column)
    Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
            cell = f.Address
        Do
            f.Offset(1).PageBreak = xlPageBreakManual
        Set f = r.FindNext(f)
        
      Loop While Not f Is Nothing And f.Address <> cell
      
    End If
    
  End If
     
Dim ws17 As Worksheet

Set ws17 = Worksheets(17)
Set oLo = ws17.ListObjects(1)

With oLo
    For i = 1 To .ListRows.Count
        If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
            If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                ws17.Rows(oLo.HeaderRowRange.Row + i).Hidden = True
            End If
        End If
    Next i
End With

    Sheets("Cover Page").Select
    Range("O1").Select

Application.Calculation = xlAutomatic
Application.ScreenUpdating = False
Application.EnableEvents = True
        
End Sub

NoSparks · Feb 18, 2022

bmkelly said:
I believe the majority of the macro is being spent with the loops

No doubt in the world about that.

How about you share a workbook with at least the largest of those *Transaction* sheets
so we can see what you're actually work with, I suspect things can be improved.

johnnyL · Feb 18, 2022

I agree. Having something to test on could almost positively ensure the speedup.

bmkelly · Feb 18, 2022

NoSparks said:
No doubt in the world about that.

How about you share a workbook with at least the largest of those *Transaction* sheets
so we can see what you're actually work with, I suspect things can be improved.

Okay! I will get on that this weekend and share with you here!

Again thank you all for helping out with this.

bmkelly · Feb 18, 2022

NoSparks said:
No doubt in the world about that.

How about you share a workbook with at least the largest of those *Transaction* sheets
so we can see what you're actually work with, I suspect things can be improved.

Are there other recommended ways to share a workbook on here thats no XL2BB? My sheet is much greater than 3000 records so I can either trim it down significantly or find a different way to share a worksheet with yall.

Test.xlsx

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

1

Customer

Department

CEID

Serial

Manufacturer

Model

Description

TriMedx Coverage

Transaction Type

Entered Date

Warranty End

Retired Date

Proration date

Transaction Date

Annual Service Price

FY Effective Price

Budgeted?

2

ST VINCENTS EAST

LABORATORY

50078116

27504

SYSMEX AMERICA, INC.

UF-1000I

URINE ANALYZERS AUTOMATED

Missing Coverage

Addition

8/5/2020

6/19/2021

$ 18,000

$ 18,542

Y

3

ST VINCENTS EAST

OR

10730182

6641721071

CARL ZEISS

OPMI PENTERO 800

MICROSCOPES LIGHT OPERATING NEUROSURGERY

All Parts & Labor

Addition

6/22/2020

6/22/2021

$ 15,000

$ 15,329

Y

4

ST VINCENTS EAST

CATH LAB

982727

(21)404824

SIEMENS MEDICAL

ACUSON SC2000

SCANNING SYSTEMS ULTRASONIC CARDIAC

Missing Coverage

Addition

5/27/2020

5/27/2021

$ 13,000

$ 14,211

Y

5

ST VINCENTS BLOUNT

RADIOLOGY

10497345

205274XRFP

GE MEDICAL SYSTEMS

FLASHPAD HD 3543

DETECTORS X-RAY DIGITAL IMAGE

All Parts & Labor

Addition

5/13/2020

5/13/2021

$ 8,800

$ 9,957

Y

6

ST VINCENTS EAST

CATH LAB

50079506

(21)20140020

SIEMENS MEDICAL

Z6MS

TRANSDUCERS ULTRASONIC TRANSESOPHAGEAL ECHOCARDIOGRAPHY

Missing Coverage

Addition

5/27/2020

5/27/2021

$ 7,500

$ 8,199

Y

7

ST VINCENTS EAST

RADIOLOGY

50077316

193730100132

CARESTREAM HEALTH

DRX PLUS 3543C

DETECTORS X-RAY DIGITAL IMAGE

All Parts & Labor

Addition

5/19/2021

5/19/2022

5/19/2021

$ 7,300

$ 8,140

N

8

ST VINCENTS BLOUNT

RADIOLOGY

50082850

1033856WK4

GE MEDICAL SYSTEMS

OPTIMA XR220AMX

RADIOGRAPHIC UNITS MOBILE DIGITAL

Missing Coverage

Addition

5/13/2020

5/11/2021

$ 7,000

$ 7,959

Y

9

ST VINCENTS EAST

OR

51291129

LM00740

BOSTON SCIENTIFIC

SWISS LITHOCLAST TRILOGY

LITHOTRIPTERS

All Parts & Labor

Addition

6/30/2021

$ 6,100

N

10

ST VINCENTS EAST

OR

50078086

1924

MIZUHO OSI

TRIOS

TABLES OPERATING SPINAL

Missing Coverage

Addition

6/2/2020

6/2/2021

$ 5,200

$ 5,599

Y

11

Apr - Jun 21 Additions Total

$ 87,900

$ 94,036

12

ST VINCENTS EAST

BIOMED

982504

249325

RAYSAFE

RAYSAFE X2

DOSIMETERS RADIATION

All Parts & Labor

Coverage Change

11/20/2017

11/20/2018

4/1/2021

$ (2,538)

$ (3,163)

N

13

ST VINCENTS BLOUNT

LABORATORY

10199019

5220

SAKURA FINETEK USA

TISSUE-TEK II CRYOSTAT

MICROTOMES CRYOSTAT

All Parts & Labor

coverage change

11/18/2015

6/14/2021

$ 1,500

$ 1,566

N

14

ST VINCENTS EAST

BIOMED

338983

M102093 / sn 1331 in bat compartmt

NETECH

MINISIM

SIMULATORS

All Parts & Labor

Coverage Change

4/8/2015

4/1/2021

$ (552)

$ (688)

N

15

ST VINCENTS EAST

REPROCESSING

EEG3474/72203967

EEG3474

SMITH & NEPHEW

LENS - 72203967

VIDEO IMAGE PROCESSORS ENDOSCOPIC

Documentation Only

Coverage Change

6/28/2017

6/28/2018

4/1/2021

$ (396)

$ (493)

N

16

ST VINCENTS EAST

REPROCESSING

EEG3382/72203967

EEG3382

SMITH & NEPHEW

LENS - 72203967

VIDEO IMAGE PROCESSORS ENDOSCOPIC

Documentation Only

Coverage Change

6/28/2017

6/28/2018

4/1/2021

$ (396)

$ (493)

N

17

ST VINCENTS EAST

ANESTHESIA

10161541

BEJU05892

DATEX OHMEDA

TEC 7 SEVO

VAPORIZERS ANESTHESIA

PM Labor Only

coverage change

2/3/2016

1/6/2015

5/10/2021

$ (280)

$ (319)

N

18

ST VINCENTS EAST

WOUND SERVICES

50026388

R294AD4544

HILL-ROM

VERSACARE P3200 SERIES

BEDS ELECTRIC FLOTATION THERAPY

Documentation Only

Coverage Change

11/7/2016

11/4/2018

4/1/2021

$ (264)

$ (329)

N

19

ST VINCENTS EAST

ANESTHESIA

587373

BEJP11581

DATEX OHMEDA

TEC 7 SEVO

VAPORIZERS ANESTHESIA

PM Labor Only

coverage change

5/3/2012

9/18/2013

5/10/2021

$ (260)

$ (296)

N

20

ST VINCENTS EAST

ANESTHESIA

916180

BEJP05630

DATEX OHMEDA

TEC 7 SEVO

VAPORIZERS ANESTHESIA

PM Labor Only

coverage change

11/25/2014

11/23/2015

5/10/2021

$ (260)

$ (296)

N

21

ST VINCENTS ST CLAIR

LABORATORY

10457825

F60C6718

ALERE

ALERE I

ANALYZERS LABORATORY MOLECULAR ASSAY

Documentation Only

Coverage Change

12/9/2016

4/1/2021

$ (223)

$ (278)

N

22

Apr - Jun 21 Coverage Changes Total

$ (3,668)

$ (4,792)

23

ST VINCENTS EAST

PRIMARY

50097299

H282AD1128

HILL-ROM

VERSACARE P3200 SERIES

BEDS ELECTRIC FLOTATION THERAPY

All Parts & Labor

Transfer

4/7/2011

7/1/2011

6/24/2021

$ -

N

24

ST VINCENTS EAST

PRIMARY

623674

H282AD1158

HILL-ROM

VERSACARE P3200 SERIES

BEDS ELECTRIC FLOTATION THERAPY

All Parts & Labor

Transfer

4/4/2011

7/1/2011

6/24/2021

$ -

N

25

ST VINCENTS EAST

BIOMED

623732

I029AD9877

HILL-ROM

VERSACARE P3200 SERIES

BEDS ELECTRIC FLOTATION THERAPY

All Parts & Labor

Transfer

4/4/2011

7/1/2011

6/10/2021

$ -

N

26

ST VINCENTS EAST

BIOMED

623715

H298AD2342

HILL-ROM

VERSACARE P3200 SERIES

BEDS ELECTRIC FLOTATION THERAPY

All Parts & Labor

Transfer

4/4/2011

7/1/2011

6/10/2021

$ -

N

27

ST VINCENTS EAST

BIOMED

623685

I016AD8576

HILL-ROM

VERSACARE P3200 SERIES

BEDS ELECTRIC FLOTATION THERAPY

All Parts & Labor

Transfer

4/4/2011

7/1/2011

6/10/2021

$ -

N

28

Apr - Jun 21 Transfers Total

$ -

29

ST VINCENTS EAST

RADIOLOGY

982746

155330100505

CARESTREAM HEALTH

DRX CORE 3543C

DETECTORS X-RAY DIGITAL IMAGE

All Parts & Labor

Retirement

1/1/2019

5/19/2021

$ (7,410)

$ (8,262)

N

30

ST VINCENTS EAST

OR

372980

174694

SIEMENS MEDICAL

ARCADIS VARIC

RADIOGRAPHIC/FLUOROSCOPIC UNITS MOBILE

Retired - No Coverage

Retirement

1/10/2008

6/25/2021

$ (7,207)

$ (7,305)

N

31

ST VINCENTS EAST

REPROCESSING

2042049A/LTF-VP

2042049A

OLYMPUS AMERICA

LTF-VP

LAPAROSCOPES VIDEO

Retired - No Coverage

Retirement

10/2/2019

10/2/2020

4/19/2021

$ (5,116)

$ (6,125)

N

32

ST VINCENTS EAST

REPROCESSING

2041960B/LTF-VH

2041960B

OLYMPUS AMERICA

LTF-VH

LAPAROSCOPES VIDEO

Retired - No Coverage

Retirement

1/29/2020

1/28/2021

4/29/2021

$ (5,116)

$ (5,985)

N

33

ST VINCENTS EAST

REPROCESSING

5000314756/8966.401

5000314756

RICHARD WOLF MEDICAL

8966.401

NEPHROSCOPES RIGID

Retired - No Coverage

Retirement

5/15/2018

7/8/2018

4/1/2021

$ (3,045)

$ (3,796)

N

34

ST VINCENTS EAST

CATH LAB

371894

2190

AVOX SYSTEMS

AVOXIMETER 1000E

OXIMETERS IN VITRO LABORATORY

Missing Coverage

Retirement

1/10/2008

6/8/2021

$ -

N

35

ST VINCENTS EAST

SICU

50025816

D123AM0214

HILL-ROM

TOTALCARE

BEDS ELECTRIC LOW AIR LOSS

Missing Coverage

Retirement

8/20/2011

6/8/2021

$ -

N

36

ST VINCENTS EAST

SICU

987254

D105AB7486

HILL-ROM

ADVANTA

BEDS ELECTRIC

Missing Coverage

Retirement

8/20/2011

6/10/2021

$ -

N

37

ST VINCENTS EAST

MICU

981659

D122AM0180

HILL-ROM

TOTALCARE

BEDS ELECTRIC LOW AIR LOSS

Missing Coverage

Retirement

1/6/2012

6/9/2021

$ -

N

38

ST VINCENTS EAST

CICU

982251

C215AM3929

HILL-ROM

TOTALCARE

BEDS ELECTRIC LOW AIR LOSS

Missing Coverage

Retirement

8/20/2011

6/10/2021

$ -

N

39

Apr - Jun 21 Retirements Total

$ (27,892)

$ (31,472)

FY22 Transactions

Cell Formulas
Range	Formula
T2:T10,T29:T38,T23:T27,T12:T21	T2	=IFERROR(([@[Annual Service Price]]/365)*('S:\TriMedx_Units\Customer Accounts\Ascension Health\STVINCENTEAST- Eastern Health Services-Birmingham, AL\FY22\FY22 Q3\Customer Summary\[FY22 Q3 East Overall CS with FY23 Updates.xlsm]Cover Page'!$AN$20-[@[Transaction Date]]),0)+[@[Proration amt]]
U2:U10,U29:U38,U23:U27,U12:U21	U2	=IFERROR(VLOOKUP([@CEID],'S:\TriMedx_Units\Customer Accounts\Ascension Health\STVINCENTEAST- Eastern Health Services-Birmingham, AL\FY22\FY22 Q3\Customer Summary\FY22 Q3 East Overall CS with FY23 Updates.xlsm'!FY22BudgetTable[[CEID]:[Budgeted]],18,FALSE),"N")
R11	R11	='S:\TriMedx_Units\Customer Accounts\Ascension Health\STVINCENTEAST- Eastern Health Services-Birmingham, AL\FY22\FY22 Q3\Customer Summary\[FY22 Q3 East Overall CS with FY23 Updates.xlsm]Cover Page'!AD5&" Additions Total"
S11:T11	S11	=SUM(S2:S10)
R22	R22	='S:\TriMedx_Units\Customer Accounts\Ascension Health\STVINCENTEAST- Eastern Health Services-Birmingham, AL\FY22\FY22 Q3\Customer Summary\[FY22 Q3 East Overall CS with FY23 Updates.xlsm]Cover Page'!AD5&" Coverage Changes Total"
S22:T22,S39:T39	S22	=SUM(S12:S21)
R28	R28	='S:\TriMedx_Units\Customer Accounts\Ascension Health\STVINCENTEAST- Eastern Health Services-Birmingham, AL\FY22\FY22 Q3\Customer Summary\[FY22 Q3 East Overall CS with FY23 Updates.xlsm]Cover Page'!AD5& " Transfers Total"
S28:T28	S28	=SUM(S23:S27)
R39	R39	='S:\TriMedx_Units\Customer Accounts\Ascension Health\STVINCENTEAST- Eastern Health Services-Birmingham, AL\FY22\FY22 Q3\Customer Summary\[FY22 Q3 East Overall CS with FY23 Updates.xlsm]Cover Page'!AD5&" Retirements Total"

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
T23	Expression	=$AA26>QUARTERDIGIT	text	NO
T24	Expression	=$AA27>QUARTERDIGIT	text	NO
S23	Expression	=$AA26>QUARTERDIGIT	text	NO
S24	Expression	=$AA27>QUARTERDIGIT	text	NO
3:3,A2:K2,M2:XFD2	Expression	=#REF!>QUARTERDIGIT	text	NO
27:27	Expression	=#REF!>QUARTERDIGIT	text	NO
13:13	Expression	=#REF!>QUARTERDIGIT	text	NO
7:7	Expression	=#REF!>QUARTERDIGIT	text	NO
A24:R24,U24:XFD24	Expression	=#REF!>QUARTERDIGIT	text	NO
17:17	Expression	=#REF!>QUARTERDIGIT	text	NO
29:30	Expression	=#REF!>QUARTERDIGIT	text	NO
20:21	Expression	=#REF!>QUARTERDIGIT	text	NO
33:33	Expression	=#REF!>QUARTERDIGIT	text	NO
35:36	Expression	=#REF!>QUARTERDIGIT	text	NO
11:11,22:22,28:28	Expression	=$AA12>QUARTERDIGIT	text	NO
5:5,A4:K4,M4:XFD4	Expression	=$AA11>QUARTERDIGIT	text	NO
31:31	Expression	=$AA39>QUARTERDIGIT	text	NO
9:9,A8:K8,M8:XFD8	Expression	=$AA22>QUARTERDIGIT	text	NO
A23:R23,U23:XFD23	Expression	=$AA27>QUARTERDIGIT	text	NO
16:16	Expression	=$AA27>QUARTERDIGIT	text	NO
25:26	Expression	=$AA28>QUARTERDIGIT	text	NO
18:19	Expression	=$AA28>QUARTERDIGIT	text	NO
12:12	Expression	=#REF!>QUARTERDIGIT	text	NO
A6:K6,M6:XFD6	Expression	=#REF!>QUARTERDIGIT	text	NO
39:39	Expression	=#REF!>QUARTERDIGIT	text	NO
32:32	Expression	=#REF!>QUARTERDIGIT	text	NO
34:34	Expression	=#REF!>QUARTERDIGIT	text	NO
L10,L8,L6,L4,L2	Expression	=#REF!>QUARTERDIGIT	text	NO
37:38	Expression	=#REF!>QUARTERDIGIT	text	NO
M10:XFD10,A10:K10	Expression	=$AA27>QUARTERDIGIT	text	NO
14:15	Expression	=$AA22>QUARTERDIGIT	text	NO

Cells with Data Validation
Cell	Allow	Criteria
M23:M27	List	Addition,Retirement, Coverage Change, Transfer
M2:M10	List	Addition,Retirement, Coverage Change, Transfer
M12:M21	List	Addition,Retirement, Coverage Change, Transfer
M29:M38	List	Addition, Retirement, Coverage Change, Transfer

Alex Blakenburg · Feb 18, 2022

bmkelly said:
other recommended ways to share a workbook

I don't know what your time zone overlap is with Johnny and NoSparks, so in case it helps keep it moving for when they come back online, the other method of sharing is to put the workbook on one of the sharing platforms such as googledrive, onedrive, dropbox. Make it available to anyone with the link and then post the link here.

I will leave working on the code with them.

NoSparks · Feb 18, 2022

Are there other recommended ways to share a workbook

I use the free file sharing site box.com, it's free and easy for individuals.

johnnyL · Feb 19, 2022

Well I was trying to use an array: Load array with DataBodyRange contents ... This part works. I make changes to the array. This part works.

The problem I encounter is that I get a run time error 1004 when attempting to write the array back to the table.

I don't hardly use Tables for the most part so I am not really familiar with them.

To load the array I use:

VBA Code:

        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header

but error 1004 when trying to write it back to the table:

VBA Code:

        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   ' Save TableArray back into the table

Maybe someone can chime in as to why this doesn't work and a way to make it work.

NoSparks · Feb 19, 2022

The time consuming loops are code I gave the OP in responses to other questions.
I think I've got it changed to filters which wouldn't be as fast as arrays but may be acceptable,
and likely easier to understand should future amendments be required.

Just waiting for a file to test with.

bmkelly · Feb 20, 2022

Sorry for the delay, been dealing with a sick bug around the house. Here is the link, let me know if you have any issues accessing it!

Test.xlsx | Powered by Box

app.box.com

NoSparks · Feb 20, 2022

Thanks bmkelly, got it.
Had a quick try and am having an issue with the filtering that needs rectified.
Now going to a one grandson's soccer game and another's hockey game so likely won't get back at this until tomorrow.

Improve VBA Code to Run Faster

bmkelly

Board Regular

NoSparks

Well-known Member

Excel Facts

johnnyL

Well-known Member

bmkelly

Board Regular

bmkelly

Board Regular

Alex Blakenburg

MrExcel MVP

NoSparks

Well-known Member

johnnyL

Well-known Member

NoSparks

Well-known Member

bmkelly

Board Regular

Test.xlsx | Powered by Box

NoSparks

Well-known Member

Similar threads

Forum statistics

Share this page

Improve VBA Code to Run Faster

Board Regular

Well-known Member

Excel Facts

Well-known Member

Board Regular

Board Regular

MrExcel MVP

Well-known Member

Well-known Member

Well-known Member

Board Regular

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock