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