Improve code using ADODB.Recordset when populate data in listbox to make fast

Hi,
this is part of my project I face really slowness in the code when add about 30 sheets and 5000 rows for each sheet.
the code will exclude row contains OPENING word in column C and row contains TOTAL word in column A for each sheet..
here is code

Sub LoadData()

    Dim s$(1), x, e, ar()
    Dim arr() As Variant, n As Long, ymd As Long
    Dim yy As Long, mm As Long, dd As Long
    
    For Each e In Array("Mussala", "mssau", "mjhgsg")
        s(0) = s(0) & IIf(s(0) = "", "", "Union All (") & "Select " & _
        "Format(`DATE`,'dd/mm/yyyy'), `INVOICE NO`, `TYPE`, `DEBIT`, `CREDIT`, " & _
        "`BALANCE` From `" & e & "$` Where `TYPE` <> 'OPENING' And `TYPE` Is Not Null " & IIf(s(0) = "", "", ") ")
    Next
    s(1) = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
         ";Extended Properties='Excel 12.0;HDR=Yes';"
    With CreateObject("ADODB.Recordset")
        .Open s(0), s(1), 3, 3, 1
        x = .GetRows
    End With
    
    
    For i = 0 To UBound(x, 2)
        
        yy = --(Right(x(0, i), 4)): mm = --(Mid(x(0, i), 4, 2)): dd = --(Left(x(0, i), 2))
        ymd = DateSerial(yy, mm, dd)
        If ymd >= Sdate And ymd <= fDate Then
            n = n + 1
            ReDim Preserve ar(0 To 5, 1 To n)
            For j = 0 To UBound(x, 1)
                ar(j, n) = x(j, i)
            Next j
        End If
    Next i
    
    With Me.ListBox1
        .ColumnCount = UBound(ar, 1) + 1
        .Column = ar
        For i = 0 To .ListCount - 1
           .List(i, 3) = Format(.List(i, 3), "#,##0.00")
           .List(i, 4) = Format(.List(i, 4), "#,##0.00")
           .List(i, 5) = Format(.List(i, 4), "#,##0.00")
        Next i
    End With

is there any chance to improve or alternative to make fast,please?