- 帖子
- 2833
- 主題
- 10
- 精華
- 0
- 積分
- 2889
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-11-15
|
2#
發表於 2019-10-27 09:44
| 只看該作者
用原來的程式碼, 300人也不須花多久時間, 在開頭加入:
Application.ScreenUpdating = False
即可加快~~
=======================================
先用[篩選]方法試試:
註：程式碼並未自動產生工作表, 若有其它科目, 須自行手動建立科目工作表,
並在 Array("英文科", "歷史科", "物理科") 中增加科目名稱
Sub 成績表分類()
Dim Sht As Worksheet
For Each Sht In Sheets(Array("英文科", "歷史科", "物理科"))
Intersect(Sht.[A:G], Sht.UsedRange).Offset(1, 0).ClearContents '清除內容
With Intersect(Sheets("成績表").[A:F], Sheets("成績表").UsedRange)
.AutoFilter Field:=3, Criteria1:=Sht.Name '以工作表名稱篩選
.Columns(1).Offset(1, 0).Resize(, 6).Copy Sht.[A2] '複製A~E欄
.Columns(6).Offset(1, 0).Copy Sht.[G2] '複製備註欄
End With
Next
Sheets("成績表").AutoFilterMode = False
End Sub
Sub 清空本表()
Intersect([A:G], ActiveSheet.UsedRange).Offset(1, 0).ClearContents
End Sub
Sub 清空各分類表()
Dim Sht As Worksheet
For Each Sht In Sheets(Array("英文科", "歷史科", "物理科"))
Intersect(Sht.[A:G], Sht.UsedRange).Offset(1, 0).ClearContents
Next
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ |
|
發表於 2019-10-26 23:45
| 
