Help to copy from multiple file and transpose data

Hi all
I have code belove to copy from multiple file to wb MAIN.xlsx sheet(ketqua), soucre range as text and result as number

Now I want this code copy then paste transpose value into sheet(ketqua), the result I want demo in sheet(ketquamongmuon)
I attack some source files to more clear

Public Sub DATA_2774()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cn As Object, rs As Object, i As Byte, lr As Long, lr2 As Long, z As Long, fso As Object
Set cn = CreateObject("adodb.connection")
Set fso = CreateObject("Scripting.FileSystemObject")
Sheets("ketqua").Range("A1").CurrentRegion.Offset(1).ClearContents
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "2774", "*.xl*"
        .InitialFileName = "nguon*"
        .AllowMultiSelect = True
        .Show
        For i = 1 To .SelectedItems.Count
            cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & .SelectedItems(i) & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
       
        Set rs = cn.Execute("select '" & fso.GetBaseName(.SelectedItems(i)) & "',val(f1) from [2774$D18:D28] ")
       
            lr = Sheets("ketqua").Range("A" & Rows.Count).End(3).Row
            If Not rs.EOF Then Sheets("ketqua").Range("A" & lr + 1).CopyFromRecordset rs
            rs.Close
            cn.Close
        Next
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub