Sub tonghop()
     Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sqlStr As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(1 To 1000, 1 To 14), a As Long
     Dim sarr, j As Long, b As Long
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
    If Not .Show = -1 Then Exit Sub
    For Each k In .SelectedItems
       Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
       ext = ";Extended Properties=""Excel 12.0;HDR=yes;IMEX= 1"";"
       cn.Open (Pro & k & ext)
       sqlStr = "Select * From [sheet1$a1:e30]"
       sarr = cn.Execute(sqlStr).GetRows
       a = a + 1
       b = Len(sarr(1, 24))
       arr(a, 1) = a
       arr(a, 2) = sarr(1, 3)
       arr(a, 3) = sarr(1, 0)
       arr(a, 4) = sarr(1, 2)
       arr(a, 5) = sarr(1, 1)
       arr(a, 9) = sarr(4, 7)
       arr(a, 10) = sarr(4, 8)
       arr(a, 11) = sarr(4, 9)
       arr(a, 12) = sarr(4, 10)
       arr(a, 13) = sarr(4, 11)
       arr(a, 14) = sarr(1, 24)
       For j = 25 To 28
          If sarr(1, j) <> Empty Then arr(a, 14) = arr(a, 14) & Chr(10) & sarr(1, j)
       Next j
       cn.Close
    Next
    End With
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 12 Then .Range("A13:N" & lr).ClearContents
         If a Then .Range("A13:N13").Resize(a).Value = arr
     End With
End Sub