yen956

『有一份六千多筆的資料』, 應是全校資料,
樓上的方法,
如不同班同姓名, 會被誤刪!!
除非一班一班人工處理

yen956

to ricky8751 & p212 大大：
抱歉, 大大的方法應可行,
只要加輔助欄, 輔助欄 填入 年級 & 班級 & 姓名,
排序後, 再將 輔助欄 視為姓名, 如上操作, 應沒問題,
思慮不周, 謹向兩位大大致歉!!

yen956

回復 6# abi
這麼久了, 問題應該早就解決了,
我只是純練功, 順便賺點數, 請不要介意, 並請指教.

1. Option Base 1
   
2. Option Explicit
   
3. Private Sub CommandButton1_Click()
   
4.     Dim i, startL, 紀錄數 As Integer
   
5.    
   
6.     紀錄數 = [A1].End(xlDown).Row - 1
   
7.    
   
8.     '(1) 按 1年級、2班級、3姓名 遞增排序
   
9.     '[A1].Resize(紀錄數 + 1, 14).Sort _
   
10.            Key1:=Range("A1"), Order1:=xlAscending, _
    
11.            Key2:=Range("B1"), Order1:=xlAscending, _
    
12.            Key3:=Range("D1"), Order1:=xlAscending, _
    
13.            Header:=xlYes
    
14.            
    
15.     '(2) 主程式
    
16.     i = 1
    
17.     Do
    
18.         i = i + 1
    
19.         If Cells(i, 4) = Cells(i + 1, 4) Then
    
20.             startL = i
    
21.             Do
    
22.                 i = i + 1
    
23.             Loop Until Cells(i, 4) <> Cells(i + 1, 4) Or Cells(i, 1) = ""
    
24.             
    
25.             '利用 複製→選擇性貼上→轉置 的方法, 可將 橫列 與 直欄 互轉
    
26.             Cells(startL, 6).Resize(i - startL + 1, 1).Copy
    
27.             
    
28.             '不能貼在原處, 要貼到 往右一格
    
29.             Cells(startL, 7).PasteSpecial Transpose:=True
    
30.         End If
    
31.     Loop Until i > 紀錄數 Or Cells(i, 1) = ""
    
32.    
    
33.     '(3) 因 (2) 不能貼在原處, 要貼到 往右一格, 故刪 除刪除原體重
    
34.     [F2].Resize(紀錄數 + 1, 1).Delete Shift:=xlToLeft
    
35.    
    
36.     '(4) 刪除 體重的空白列
    
37.     For i = 紀錄數 + 1 To 2 Step -1
    
38.         If Cells(i, 6) = "" Then Rows(i).Delete
    
39.     Next
    
40. 
    
41.     '(5) 按 1年級、2班級、3座號 遞增排序
    
42.     '[A1].Resize(紀錄數 + 1, 14).Sort _
    
43.            Key1:=Range("A1"), Order1:=xlAscending, _
    
44.            Key2:=Range("B1"), Order1:=xlAscending, _
    
45.            Key3:=Range("C1"), Order1:=xlAscending, _
    
46.            Header:=xlYes
    
47. End Sub

複製代碼