Why is this code so slow?

Hi all,

this code is running insanely slow (measured in minutes rather than seconds). Bearing in mind that the number of 'cells' is going to be no more than 200, why should this be the case? I can't think of anyway to speed this up. Can't really share the full file as it is chock full of personal details, but any questions please ask.

For Each cell In Sheets("Personal").Range("A2:A" & rCnt) '''CYCLE THROUGH EVERY CCODE
        appCount = Application.WorksheetFunction.CountIf(apprange, cell) '''COUNT APPLICATIONS MADE BY EACH CCODE
        subCount = Application.WorksheetFunction.CountIf(subrange, cell) '''COUNT SUBJECTS STUDIED BY EACH CCODE
        gapCount = Application.WorksheetFunction.Max(appCount, subCount) '''ASCERTAIN HIGHEST NUMBER FOR THE PURPOSES OF LAYOUT LATER
        On Error Resume Next
        appRow = Application.WorksheetFunction.Match(cell, Sheet33.Range("A:A"), 0) '''WHICH ROW DOES THE APPLICATIONS LIST START FOR CCODE
        subrow = Application.WorksheetFunction.Match(cell, Sheet2.Range("A:A"), 0) '''WHICH ROW DOES SUBJECTS LIST START FOR CCODE
        
        name = cell.Offset(0, 4)
        
        newcell.Value = name
        i = 0
        For i = 0 To subCount - 1
            newcell.Offset(i, 1).Value = Sheet2.Range("B" & subrow + i)
            newcell.Offset(i, 2).Value = Sheet2.Range("D" & subrow + i)
            newcell.Offset(i, 3).Value = Sheet2.Range("E" & subrow + i)
            newcell.Offset(i, 4).Value = Sheet2.Range("F" & subrow + i)
            newcell.Offset(i, 5).Value = Sheet2.Range("G" & subrow + i)
        Next i
        
        j = 0
        For j = 0 To appCount - 1
            newcell.Offset(j, 6).Value = Sheet33.Range("B" & appRow + j)
            newcell.Offset(j, 7).Value = Sheet33.Range("C" & appRow + j)
            newcell.Offset(j, 8).Value = Sheet33.Range("D" & appRow + j)
        Next j
        
        Set newcell = ws.Range("A6500").End(xlUp).Offset(gapCount)
        newcount = newcount + gapCount
        Rows(newcount).Select
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlMedium
            End With
        
    Next

This is the effect I am after:
tableexample.jpg

You haven't provided us with how you calculate 'RCnt', this may be the issue.

whoops, sorry:

rCnt = Sheets("Personal").Range("B6500").End(xlUp).Row

Can you provide a before and after screenshot of what it is you want to achieve?

The picture attached to the OP is what it is supposed to come out like. The code begins by wiping all info from "A2:I6500" with clearcontents (leaving the heading row).

The idea then is that it works out whether the student is studying more subjects or applying for more universities (and uses this information to workout where to put the separation line.)

The purpose of this is that rather than manually creating the report and giving every student 8 spaces for example, I could save trees by restricting their entry to just the required area.

I hope that makes sense

Without knowing what the input data looks like (and all of the code), I'm afraid I can't really offer any solutions as to the speed.

OK.

I hope I've stripped the identifying data from the spreadsheet. So here it is (had to zip a file 'cos it's >1000kb - I think that's a lot to do with other conditional formatting etc):StudentReport.zip

The module that I'm referring to in this post is 'RunTheGrid'

OK. Thanks for input. I'd like to have tried something on Access, but no access to it on these work computers. Generally don't know enough about functions that would allow me to do this without VBA, and as I am teaching myself as I go along I am not sure how I put this stuff into an array and then back again. I guess I am in for some heavy reading....

:-)

Thanks for your input guys. I have done some reading, and although I could have gone for the pivot table option, I do not need to access this information for reporting basis - it's simply a print out for my bosses. So with the power of arrays I have significantly streamlined the code, and it completes in less than a minute. Still not rocket speed, but more than enough for what I'll be using it for.

Thank you for all your help. Here is what I ended up with:

rCnt = Sheet1.Range("B6500").End(xlUp).Row

ccArr = Sheet1.Range("A2:A" & rCnt)

For i = LBound(ccArr) To UBound(ccArr)
    If i > 1 Then ''' works on every record after the first one
        gapCount = Application.WorksheetFunction.Max(subCount, appCount) ''' calculate whether more subs or apps so as to know where to put the next student details
        RowCount = Sheet42.Range("A2").CurrentRegion.Rows.Count + 1
        Sheet42.Range("A" & RowCount).Value = Application.WorksheetFunction.VLookup(ccArr(i, 1), Range("StudentData"), 5, False) ''' GET THE NAME FROM CCODE
    Else:   gapCount = 0 ''' ONLY ON FIRST RECORD
            RowCount = 2
            Sheet42.Range("A2").Value = Application.WorksheetFunction.VLookup(ccArr(i, 1), Range("StudentData"), 5, False)
    End If
    
    With Application.WorksheetFunction
    On Error Resume Next
        appRow = 0 ''' Reset the row counts - PARTICULARLY RELEVANT IF NO APPLICATIONS MADE
        subRow = 0
        appRow = .Match(ccArr(i, 1), Sheet33.Range("A:A"), 0)
        subRow = .Match(ccArr(i, 1), Sheet2.Range("A:A"), 0)
        appCount = .CountIf(apprange, ccArr(i, 1))
        subCount = .CountIf(subrange, ccArr(i, 1))
    End With
    
    subArr = Sheet2.Range("C" & subRow & ":G" & subRow + subCount - 1)
    If IsError(Sheet33.Range("B" & appRow & ":D" & appRow + appCount - 1)) Then ''' APPLICATIONS ARRAY IS LIKELY TO BE A BIT DODGY IF THERE IS NO APPLICATIONS MADE
        Erase appArr ''' RESETS THE ARRAY TO NOTHING
    Else: appArr = Sheet33.Range("B" & appRow & ":D" & appRow + appCount - 1)
    End If
    
    Sheet42.Range("B" & RowCount).Resize(UBound(subArr, 1), UBound(subArr, 2)) = subArr
    Sheet42.Range("G" & RowCount).Resize(UBound(appArr, 1), UBound(appArr, 2)) = appArr
    
    
    ''' ADD LINE UNDER EACH STUDENT
    If gapCount = 0 Then
        Rows(i + Application.WorksheetFunction.Max(subCount, appCount)).Select
    Else: Rows(RowCount + Application.WorksheetFunction.Max(subCount, appCount) - 1).Select
    End If
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ThemeColor = 1
                .TintAndShade = -0.249946592608417
                .Weight = xlMedium
            End With
       
Next

Cells.Select
Selection.Columns.AutoFit

Application.ScreenUpdating = True

lcell = Sheet42.UsedRange.Rows.Count
reprange = "A2:I" & lcell
Range(reprange).Select


ActiveSheet.PageSetup.PrintArea = reprange
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .CenterHeader = "&""-,Bold""&14Application Grid - " & Format(Date, "dd/mm/yy")
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
    End With
    Application.PrintCommunication = True
    Sheet42.PrintPreview