归纳与总结，以备自查！

liaotian1

ctp_119 发表于 2016-8-15 16:28
明天有时间帮你看一下！！！

说明：附件已更新

按总评分排名.rar (31.13 KB, 下载次数: 7)

2016-8-16 05:43 上传

点击文件名下载附件

kszcs

留下记号，谢谢楼主

ctp_119

liaotian1 发表于 2016-8-16 05:43
说明：附件已更新

1. Sub 语文排名()
   
2. Dim i As Double
   
3. Dim j As Integer
   
4. Dim arr As Variant
   
5. Dim rng As Range
   
6. j = 6
   
7. i = Range("a6").End(xlDown).Row
   
8. Do While i < 100
   
9. arr = Range(Cells(j, "K"), Cells(i, "k")).Value
   
10. 100:
    
11. For s = 1 To UBound(arr) - 1
    
12.     If arr(s, 1) < arr(s + 1, 1) Then
    
13.         temp = arr(s + 1, 1)
    
14.         arr(s + 1, 1) = arr(s, 1)
    
15.         arr(s, 1) = temp
    
16.         GoTo 100
    
17.     End If
    
18. Next s
    
19. For Each rng In Range(Cells(6, "K"), Cells(i, "k"))
    
20.     For s = 1 To UBound(arr)
    
21.         If rng.Value = arr(s, 1) Then
    
22.             rng.Offset(, 1) = s
    
23.         End If
    
24.     Next s
    
25. Next
    
26. j = i + 2
    
27. i = Range("A" & i + 2).End(xlDown).Row
    
28. Loop
    
29. End Sub
    

复制代码

ctp_119

其他同底可得！！！！


按总评分排名.zip (34.55 KB, 下载次数: 18)

2016-8-16 10:32 上传

点击文件名下载附件

送人亲

先mark一下，以后继续学习，谢谢！

15817453287

大神，能帮忙做几个教务常用的模版吗？比如这篇文章中的
http://wenku.baidu.com/link?url=nuIt1bpqGqfhPlj9g7_NgyZfPcneIHCS33USQQHR1xNxjUPAd_y27tIwOA6bsE8ZAdHlbrjKDsvq8jJpkXmpurhyiByke36ZBsjYw5RR03G
这些模版我觉得都好棒啊！就是自己不会做，我在高中做教务，一个年级就将近1000人，三个年级3000人，各种数据、排名、考试、考号、监考人员安排什么的真的好要命啊~！

weiyingde

好东西，遗憾不能按照版主的意思跟帖，但还是要做个记号，以备学习和查询。

edo20

感谢楼主，点赞分享

ctp_119

1. Sub tiqu()
   
2. On Error GoTo errorline
   
3. Dim appword As Word.Application
   
4. Dim doc As Word.Document
   
5. Dim p As String
   
6. Dim str As String
   
7. Dim st As String
   
8. Dim mytable As Table
   
9. Dim irow As Integer
   
10. Dim rngparagraph As Word.Range
    
11. Application.ScreenUpdating = False
    
12. irow = 2
    
13. Range("a2:i999").ClearContents
    
14. Set appword = GetObject(, "word.application")
    
15. p = ThisWorkbook.Path
    
16. str = Dir(p & "\*.doc")
    
17. Do Until str = ""
    
18.     Set doc = appword.Documents.Open(p & "" & str, ConfirmConversions:=False, ReadOnly:= _
    
19.         False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
    
20.         "", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
    
21.         Format:=wdOpenFormatAuto, XMLTransform:="")
    
22.         Set rngparagraph = ActiveDocument.Paragraphs(2).Range
    
23.         st = rngparagraph.Text
    
24.         Set mytable = doc.Tables(1)
    
25.         Cells(irow, 1) = VBA.Trim$(Mid(st, 7, 7))
    
26.         Cells(irow, 2) = VBA.Trim$(mytable.Cell(3, 3).Range)
    
27.         Cells(irow, 3) = VBA.Trim$(Left(Right(st, 6), 5))
    
28.         Cells(irow, 4) = VBA.Trim$(mytable.Cell(15, 6).Range)
    
29.         Cells(irow, 5) = VBA.Trim$(mytable.Cell(16, 6).Range)
    
30.         Cells(irow, 6) = VBA.Trim$(mytable.Cell(20, 3).Range)
    
31.         Cells(irow, 7) = VBA.Trim$(mytable.Cell(23, 3).Range)
    
32.      doc.Close False
    
33.      irow = irow + 1
    
34.      str = Dir
    
35. Loop
    
36. errorexit:
    
37.     Application.ScreenUpdating = True
    
38.     Set appword = Nothing
    
39.     Exit Sub
    
40. errorline:
    
41.     If Err.Number = 429 Then
    
42.         Set appword = CreateObject("word.application")
    
43.         Resume Next
    
44.     Else
    
45.         MsgBox "错误号：" & Err.Number & "错误提示：" & Err.Description
    
46.         Resume errorexit
    
47.     End If
    
48.    
    
49. End Sub
    

复制代码

从word文档中提取数据到excel中的实例！！！

ctp_119

ctp_119 发表于 2016-11-24 15:54
从word文档中提取数据到excel中的实例！！！

注意getobject和createobject函数的区别和联系！！！