T4505_Fill School Table Using Arrays

https://excel-egy.com/forum/t4505
---------------------------------

Sub Fill_School_Table_Using_Arrays()
    Dim a, b, x, ws As Worksheet, sh As Worksheet, foug As String, i As Long, j As Long, c As Long

    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        sh.Range("E9:X16").ClearContents
        a = ws.Range("B3:P" & ws.Cells(Rows.Count, "B").End(xlUp).Row).Value
        ReDim b(1 To 8, 1 To 20)
        foug = sh.Range("L5").Value

        For i = LBound(a) To UBound(a)
            If a(i, 7) = foug Then
                x = Application.Match(a(i, 6), sh.Range("E7:U7"), 0)
                If Not IsError(x) Then
                    c = x
                    For j = 1 To 8
                        If a(i, 1) = j Then
                            b(j, c) = IIf(b(j, c) = Empty, a(i, 2), b(j, c) & "|" & a(i, 2))
                            b(j, c + 1) = IIf(b(j, c + 1) = Empty, a(i, 3), b(j, c + 1) & "|" & a(i, 3))
                            b(j, c + 2) = IIf(b(j, c + 2) = Empty, a(i, 8), b(j, c + 2) & "|" & a(i, 8))
                            b(j, c + 3) = IIf(b(j, c + 3) = Empty, a(i, 10), b(j, c + 3) & "|" & a(i, 10))
                        End If
                    Next j
                End If
            End If
        Next i

        sh.Range("E9").Resize(UBound(b, 1), UBound(b, 2)).Value = b
    Application.ScreenUpdating = True
End Sub