Board logo

標題: [發問] 如何在多個excel檔中找出資料，然後在同一個檔中排序 [打印本頁]
作者: eternal001    時間: 2011-8-1 20:49     標題: 如何在多個excel檔中找出資料，然後在同一個檔中排序

本帖最後由 eternal001 於 2011-8-1 20:57 編輯

假設有很多個excel檔
[attach]7232[/attach][attach]7233[/attach]
要在另一個檔案中找到這些檔案的總平均
每一個檔中
他們擁有的科目不一定一樣多
只是最後都會有一個總平均值
他們的名字就是檔名
然後在另一個檔排序他們的名次
[attach]7234[/attach]
因為資料有上千筆
所以不知要怎麼去抓資料排序

請高手幫忙解答
作者: luhpro    時間: 2011-8-1 23:00

本帖最後由 luhpro 於 2011-8-1 23:01 編輯

回復 1# eternal001
  1. Private Sub cbLoad_Click()
  2.   Dim lRow As Long, lCount As Long
  3.   Dim sPath$, sFName$, sName$, sTheName$
  4.   Dim bTranFile As Boolean
  5.   Dim vSou
  6.   
  7.   sPath = ThisWorkbook.Path    ' 指定路徑為本檔案所在的的目錄
  8.   bTranFile = False ' 紀錄是否有讀到檔案
  9.   With Me ' 本 Sheet 即 Sheet1
  10.     .Cells.Clear ' 清資料
  11.     .Cells(1, 1) = "排名" ' 標題
  12.     .Cells(1, 2) = "人名"
  13.     .Cells(1, 3) = "總分"
  14.     lRow = 2 ' 從第二列開始放資料
  15.     lCount = 0 ' 讀取資料檔案數量
  16.     sTheName = Me.Parent.Name ' 本檔案的目錄
  17.     sFName = Dir(sPath & "\*.xls")   ' 找尋第一個Excel檔案
  18.     Do While sFName <> ""    ' 執行迴圈。
  19.       If sFName <> sTheName Then ' 跳過本檔案
  20.         bTranFile = True
  21.         sName = Left(sFName, Len(sFName) - 4) ' 截取人名
  22.         sFName = sPath & "\" & sFName ' 檔案全名
  23.         Workbooks.Open Filename:=sFName, ReadOnly:=True ' 開檔
  24.         Set vSou = ActiveWorkbook.Sheets(1) '設定 Sheet(1) 物件給 vSou
  25.         Workbooks(sTheName).Activate ' 焦點切回原Sheet
  26.         .Cells(lRow, 1) = lRow - 1 ' 排名
  27.         .Cells(lRow, 2) = sName '人名
  28.         .Cells(lRow, 3) = Round(vSou.Cells(vSou.Cells(1, 1). _
  29.                           CurrentRegion.Find("總平均").Row, 2)) '總分
  30.         lRow = lRow + 1 ' 列號 + 1
  31.         lCount = lCount + 1 ' 讀取檔案數 + 1
  32.       End If
  33.       If sFName <> sTheName Then Workbooks(sName & ".xls").Close ' 關閉本檔案以外開啟的檔案
  34.       sFName = Dir    ' 尋找下一個檔案
  35.     Loop
  36.     .Range(.Cells(2, 2), .Cells(lRow, 3)).Sort Key1:=.Cells(1, 3), order1:=xlDescending ' 以總分為鍵值做排序
  37.   End With
  38.   
  39.   If Not bTranFile Then
  40.     MsgBox ("找不到任何資料檔案...")
  41.     Exit Sub
  42.   Else
  43.     MsgBox ("資料讀取完成, 共讀取 " & lCount & " 個檔案...")
  44.     Exit Sub
  45.   End If
  46. End Sub
複製代碼
[attach]7241[/attach]
作者: GBKEE    時間: 2011-8-2 17:09

回復 2# luhpro
修改你的程序請參考參考
  1. Sub Ex()
  2.     Dim Ar(), S As Integer, sPath As String, sFName As String
  3.     ReDim Ar(1, S)
  4.     sPath = ThisWorkbook.Path    ' 指定路徑為本檔案所在的的目錄
  5.     sFName = Dir(sPath & "\*.xls")   ' 找尋第一個Excel檔案
  6.     Do While sFName <> ""    ' 執行迴圈。
  7.         If sFName <> ThisWorkbook.Name Then  ' 開啟本檔案以外的檔案
  8.             ReDim Preserve Ar(1, S)
  9.             With Workbooks.Open(sPath & "\" & sFName) ' 開檔
  10.                 With .Sheets(1).Cells.Find("總平均")
  11.                     Ar(0, S) = Mid(sFName, 1, InStrRev(sFName, ".") - 1)
  12.                     Ar(1, S) = Cells(1, 2)
  13.                 End With
  14.                 .Close
  15.             End With
  16.             S = S + 1
  17.         End If
  18.         sFName = Dir    ' 尋找下一個檔案
  19.     Loop
  20.     Range("A:C") = ""
  21.     Range("A1:C1") = Array("排名", "人名", "總平均")
  22.     Range("B2").Resize(S, 2) = Ar
  23.     Range("A1").CurrentRegion.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes
  24.     With Range("A2:A" & Range("B2").End(xlDown).Row)
  25.         .Value = "ROW()-1"
  26.         .Value = .Value
  27.     End With
  28.   If S = 0 Then
  29.     MsgBox ("找不到任何資料檔案...")
  30.   Else
  31.     MsgBox ("資料讀取完成, 共讀取 " & S - 1 & " 個檔案...")
  32.   End If
  33. End Sub
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)