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 
