如何在多個excel檔中找出資料，然後在同一個檔中排序 - Excel程式區

[發問] 如何在多個excel檔中找出資料，然後在同一個檔中排序

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2011-8-2 17:09 | 顯示全部帖子

回復 2# luhpro
修改你的程序請參考參考

Sub Ex()
Dim Ar(), S As Integer, sPath As String, sFName As String
ReDim Ar(1, S)
sPath = ThisWorkbook.Path ' 指定路徑為本檔案所在的的目錄
sFName = Dir(sPath & "\*.xls") ' 找尋第一個Excel檔案
Do While sFName <> "" ' 執行迴圈。
If sFName <> ThisWorkbook.Name Then ' 開啟本檔案以外的檔案
ReDim Preserve Ar(1, S)
With Workbooks.Open(sPath & "\" & sFName) ' 開檔
With .Sheets(1).Cells.Find("總平均")
Ar(0, S) = Mid(sFName, 1, InStrRev(sFName, ".") - 1)
Ar(1, S) = Cells(1, 2)
End With
.Close
End With
S = S + 1
End If
sFName = Dir ' 尋找下一個檔案
Loop
Range("A:C") = ""
Range("A1:C1") = Array("排名", "人名", "總平均")
Range("B2").Resize(S, 2) = Ar
Range("A1").CurrentRegion.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes
With Range("A2:A" & Range("B2").End(xlDown).Row)
.Value = "ROW()-1"
.Value = .Value
End With
If S = 0 Then
MsgBox ("找不到任何資料檔案...")
Else
MsgBox ("資料讀取完成, 共讀取 " & S - 1 & " 個檔案...")
End If
End Sub

複製代碼

靜思自在 : 【行善要及時】行善要及時，功德要持續。如燒開水一般，未燒開之前千萬不要停熄火候，否則重來就太費事了。