返回列表 上一主題 發帖

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

eternal001

帖子
1 
主題
1 
精華
0 
積分
7 
點名
0  
作業系統
XP 
軟體版本
office 2003 
閱讀權限
10 
性別
男 
註冊時間
2011-8-1 
最後登錄
2011-8-1 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-8-1 20:49 | 只看該作者

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

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

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

請高手幫忙解答

多筆資料排序.rar (18.33 KB)

收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 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
複製代碼
排序-A.zip (13.08 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 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
複製代碼

TOP

        靜思自在 : 好事要提得起，是非要放得下，成就別人即是成就自己。
返回列表 上一主題