VBA populating cells with an array (code works but very slow sometimes)

Append Criteria Columns

Option Explicit

Sub inhoudsopgave()

    ' Define constants.

    ' Source
    Const sRows As String = "5:70"
    Const sColsList As String = "A,D,AM"
    Const sAddress As String = "AI3"
    Dim swsNamesList As String: swsNamesList _
        = "1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20," _
        & "21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40," _
        & "41,42,43,44,45,46,47,48,49,50"
    ' Destination
    Const dName As String = "INHHULP"
    Const dFirstCellAddress As String = "A2"
    Const dIdColumn As String = "F"
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Split the values from the strings to string arrays.
    Dim swsNames() As String: swsNames = Split(swsNamesList, ",")
    Dim sCols() As String: sCols = Split(sColsList, ",")
    
    ' Determine the size of the arrays ('cArr') in the jagged array.
    Dim cUpper As Long: cUpper = UBound(sCols)
    Dim cArr() As Variant: ReDim cArr(0 To cUpper + 2)
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    ' Use the destination worksheet to calculate the number of rows
    ' identified by the 'sRows' constant, the address of the rows
    ' in the source worksheets.
    Dim srCount As Long: srCount = dws.Rows(sRows).Rows.Count
    
    ' Write the values from the source ranges to arrays located in the first
    ' columns of the arrays of a jagged array ('Jag'). Write the titles
    ' to the column before the last column of the jagged array.
    ' Shift the matching values to the beginning of the arrays
    ' and write the number of matches to the last column.
    
    Dim nUpper As Long: nUpper = UBound(swsNames)
    Dim Jag() As Variant: ReDim Jag(1 To nUpper + 1)
    
    Dim sws As Worksheet
    Dim scrg As Range
    Dim sr As Long
    Dim n As Long
    Dim j As Long
    Dim c As Long
    Dim dr As Long
    Dim drCount As Long
    
    For n = 0 To nUpper ' all worksheets
        On Error Resume Next
            Set sws = wb.Worksheets(swsNames(n))
        On Error GoTo 0
        If Not sws Is Nothing Then ' the worksheet exists
            j = j + 1 ' found worksheets
            Jag(j) = cArr
            For c = 0 To cUpper
                Jag(j)(c) = sws.Rows(sRows).Columns(sCols(c)).Value
            Next c
            Jag(j)(c) = sws.Range(sAddress).Value
            For sr = 1 To srCount
                If Len(Jag(j)(0)(sr, 1)) > 0 Then
                    dr = dr + 1
                    For c = 0 To cUpper
                        Jag(j)(c)(dr, 1) = Jag(j)(c)(sr, 1)
                    Next c
                    Jag(j)(c + 1) = dr
                 End If
            Next sr
            drCount = drCount + dr
            dr = 0
            Set sws = Nothing
        'Else ' the worksheet doesn't exist; do nothing
        End If
    Next n
    
    ' Write the values from the jagged array to the destination array ('dData').
    
    Dim dcCount As Long: dcCount = cUpper + 2
    
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    Dim Item As Variant
    Dim r As Long
    
    For j = 1 To j
        For dr = 1 To Jag(j)(cUpper + 2)
            r = r + 1
            For c = 0 To cUpper
                dData(r, c + 1) = Jag(j)(c)(dr, 1)
            Next c
            dData(r, c + 1) = Jag(j)(c)
        Next dr
    Next j
    
    ' Reference the destination range ('drg').
    Dim drg As Range
    Set drg = dws.Range(dFirstCellAddress).Resize(drCount, dcCount)
    
    ' Write the values from the destination array to the destination range.
    drg.Value = dData
    
    ' Clear below.
    drg.Resize(dws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear
    
    ' Generate and write the id column.
    Dim dirg As Range: Set dirg = drg.EntireRow.Columns(dIdColumn)
    dirg.Value = dws.Evaluate("ROW(1:" & drCount & ")")
    
    ' Inform.
    MsgBox "Inhoudsopgave is gegenereerd", vbInformation

End Sub