I have two large worksheets that I need to consolidate select data into one worksheet. Both worksheets contain about 80K+ rows, the output is expected to be in that range as well. At this point in time, the code works, but it is extremely slow. I don't actually know how long it actually takes to run on the full data set. I have let is run for 8+ hours without having it finish.
The procedure uses a for each loop to move through all the rows of the primary worksheet wsICD10 and selects all rows of concern (based on the criteria in the if statement) and logs the LOS_Group for use later in the VBA autofilter of the wsDUNST15 worksheet. I use two nested for loops to exhaustively extract all the data from the wsDUNST15. Once all my variables are full I write them to my new workbook and move on to the next record of interest in my wsICD10 with the for each loop.
My guess is the combination of nested loops and auto-filtering the large worksheets is an inefficient way to complete my task. But I'm unaware of another way to select a worksheet row using multiple criteria.
Public Sub ICD10DataSet()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create ICD-10-CM/PCS data set
'
'ICD10_Type | ageCategory | DiagnosisProcedure_Category | ICD10_Code | LOS_Group | AVG_Stay
'
'
' This will use Truven October, 2017 data files
'
' By Trevor Pye
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim wb As Workbook
Dim wbData As Workbook
Dim ICD10_Data As Worksheet
Dim wsICD10 As Worksheet
Dim wsDUNST15 As Worksheet
Dim ICD_Cell As Range
Dim ICD_Range As Range
Dim ICD10_Type As String
Dim AgeCat As Integer
Dim diagProced_Cat As Integer
Dim ICD10_Code As String
Dim LOS_Group As String
Dim AVG_Stay As Double
Dim startTime As Double
Application.ScreenUpdating = False
startTime = Time
Set wb = Workbooks("LOS_WorkBookICD-10_201710.xlsm")
Set wbData = Workbooks.Add
Set wsICD10 = wb.Worksheets("ICD10Full")
Set wsDUNST15 = wb.Worksheets("DUNST15")
Set wsOUNST15 = wb.Worksheets("OUNST15")
Set ICD_Range = wsICD10.Range("A2", wsICD10.Range("A1048576").End(xlUp))
Set ICD_Cell = wsICD10.Range("A2")
Set ICD10_Data = wbData.Sheets(1)
ICD10_Data.Range("A1") = Format(startTime, "HH:MM:SS")
'---- Start Header with block -------
With ICD10_Data
.Cells(2, 1).Value = "ICD10_Type"
.Cells(2, 2).Value = "ageCategory"
.Cells(2, 3).Value = "DiagnosisProcedure_Category"
.Cells(2, 4).Value = "ICD10_Code"
.Cells(2, 5).Value = "LOS_Group"
.Cells(2, 6).Value = "AVG_Stay"
End With
'---- Header Header with block -------
t = 3 '<--- starting row number
' define ICD_Type, ICD10_Code, LOS_Group
'-----Start ICD10 Code loop ----
For Each ICD_Cell In ICD_Range
If ICD_Cell.Offset(, 4) = "@" Or ICD_Cell.Offset(-1, 2) = ICD_Cell.Offset(0, 2) Or ICD_Cell.Offset(, 12) = "" Then
GoTo SkipCodeBlock '<--- Row not of interest, skip to next row
Else
ICD10_Code = ICD_Cell.Offset(0, 2).Value
LOS_Group = ICD_Cell.Offset(, 12)
ICD10_Type = ICD_Cell.Value
End If
'-------Start of nested diagnosis Loops ----------
If ICD10_Type = "D" Then
For i = 1 To 5
AgeCat = i ' <--- setting the Age category integer value
For j = 1 To 4
Select Case j ' <--- setting the diagnosis integer value
Case 1
diagProced_Cat = 0
Case 2
diagProced_Cat = 1
Case 3
diagProced_Cat = 3
Case Else
diagProced_Cat = 4
End Select
With wsDUNST15.UsedRange '<-- retrieving the row of interest
.AutoFilter field:=4, Criteria1:=LOS_Group
.AutoFilter field:=5, Criteria1:=diagProced_Cat
.AutoFilter field:=6, Criteria1:=AgeCat
End With
AVG_Stay =
(wsDUNST15.Range(wsDUNST15.Range("H1048576").End(xlUp),
"H2").SpecialCells(xlCellTypeVisible).Value)/10
wsDUNST15.ShowAllData ' <---Resetting filters
With ICD10_Data ' log Results
finalRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(t, 1).Value = ICD10_Type
.Cells(t, 2).Value = AgeCat
.Cells(t, 3).Value = diagProced_Cat
.Cells(t, 4).Value = ICD10_Code
.Cells(t, 5).Value = "'" & LOS_Group
.Cells(t, 6).Value = AVG_Stay
End With
t = t + 1
Next j
Next i
Else
GoTo complete
End If
'-------End of nested diagnosis Loops -------
SkipCodeBlock:
Next ICD_Cell
'------End ICD10 Code loop -----
Application.ScreenUpdating = True
complete:
endTime = Time
ICD10_Data.Range("b1") = Format(endTime, "HH:MM:SS")
MsgBox "Procedure Complete!"
End Sub
