test是主档
这个程序目前只能导入2个excel工作簿
需要改成导入文件夹下多个excel档案,大约有6~7个工作簿
反红色部份,请问需要如何做修改？谢谢

主档G列部份输入执行程序,会导入其他工作簿寻找一样ID
要是遇到相同ID,则会依照时间比对搜寻最近一笔ID  显示在I列
请大神们帮忙简单化一下程序,谢谢



Sub xx2()
Dim Cn As Object, ar, i&, p$, f$, Sq$(2), s$, qstr$
qstr = "select ee.代码 from  [Sheet1$g1:g1000]  as aa left join ( select  bb.条形码,bb.代码,cc.sj as 时间 from  " & _
"(SELECT 条形码,代码,状态,时间 FROM [Excel 12.0;Database=C:\Users\X\Desktop\TEST\scra.xls].[$A1:N] " & _
"            WHERE 条形码 IS NOT NULL UNION ALL " & _
"            SELECT 条形码,代码,状态,时间 FROM [Excel 12.0;Database=C:\Users\X\Desktop\TEST\SHIPP.xls].[$A1:N]  " & _
"            WHERE 条形码 IS NOT NULL) as bb inner join  (SELECT 条形码, max(时间) as sj FROM  ( " & _
"SELECT 条形码,代码,状态,时间 FROM [Excel 12.0;Database=C:\Users\X\Desktop\TEST\scra.xls].[$A1:N]  " & _
"            WHERE 条形码 IS NOT NULL UNION ALL " & _
"            SELECT 条形码,代码,状态,时间 FROM [Excel 12.0;Database=C:\Users\X\Desktop\TEST\SHIPP.xls].[$A1:N]  " & _
"            WHERE 条形码 IS NOT NULL) group by 条形码 ) as cc   " & _
"on bb.条形码  = cc.条形码  and  bb.时间 = cc.sj) as ee on aa.条形码  = ee.条形码  "

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
  s = "Excel 8.0;Database="
  Cn.Open "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
Else
  Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  s = "Excel 12.0;Database="
End If
With Worksheets(1)
  .Activate
  Sq(0) = "[" & .Name & "$g1:g" & .Cells(.Rows.Count, "g").End(xlUp).Row & "]a"
End With
p = ThisWorkbook.Path & "\"
ar = Array("scra.xls", "SHIPP.xls")
For i = 0 To UBound(ar)
  f = p & ar(i)
  If Dir(f, vbDirectory) <> "" Then
   Sq(1) = Sq(1) & " UNION ALL SELECT 条形码,代码,状态,时间 FROM [" & s & f & "].[$A1:N] WHERE 条形码 IS NOT NULL"
  End If
Next
Sq(1) = "SELECT * FROM (" & Mid(Sq(1), 12) & ") ORDER BY 时间"
Sq(1) = "SELECT 条形码,LAST(代码) AS 代码,LAST(状态) AS 状态,MAX(时间) AS 时间 FROM (" & Sq(1) & ") GROUP BY 条形码"
Sq(2) = "SELECT b.代码 FROM " & Sq(0) & " LEFT JOIN (" & Sq(1) & ")b ON a.条形码=b.条形码"
Range("H3:i99").ClearContents

Range("i2").CopyFromRecordset Cn.Execute(qstr)

Cn.Close
Set Cn = Nothing
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub