烦人的光荣榜
作者：互联网
广告公司说不会从Excel里复制表格，然后粘贴到图片上面。只会从Word里复制表格，然后粘贴到照片里面。最后也不知道是谁拍板定下的广告公司，把要光荣榜做成word文档，真是闻所未闻！这种情况还持续了好几年。
等你忍无可忍你写了一段代码，想着以后能高效一点，它就改格式了，tnnd。真希望上面的人有点脑子，行不咯
班级前十
Sub 班级前十()
'实例化对象
Set Wb = Application.ThisWorkbook
DataPath = Wb.FullName
Set DataSht = Wb.Worksheets("期中考试2")
Set sht = Wb.Worksheets("光荣榜班级前十")
Dim DATA_ENGINE As String
Select Case Application.Version * 1
Case Is <= 11
DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
Case Is >= 12
DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
End Select
Set cnn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
cnn.Open DATA_ENGINE & DataPath
With sht
Sql = "SELECT 姓名,总分d,总分d科类排名,总分d班级排名 FROM [" & DataSht.Name & "$A1:cZ] WHERE 班级=" & class & _
" and (总分d班级排名 between 1 and 10 ) order by 总分d班级排名 asc"
'Set rs = CNN.Execute(Sql)
rs.Open Sql, cnn, 1, 3
If rs.RecordCount > 0 Then
.Cells.Clear
i = 0
Do
i = i + 1
.Cells((i - 1) * 3 + 1, 1).Resize(1, 4).Value = Array("姓名", "总分", "科类排名", "班级排名")
For j = 0 To rs.Fields.Count - 1
.Cells((i - 1) * 3 + 2, j + 1).Value = rs.Fields(j)
Next j
SetBordersAndCenters .Cells((i - 1) * 3 + 1, 1).CurrentRegion
rs.MoveNext
Loop Until rs.EOF
End If
End With
rs.Close
cnn.Close
Set Wb = Nothing
Set DataSht = Nothing
Set sht = Nothing
Set cnn = Nothing
Set rs = Nothing
End Sub
单科第一
Sub 单科第一()
'实例化对象
Set Wb = Application.ThisWorkbook
DataPath = Wb.FullName
Set DataSht = Wb.Worksheets("期中考试2")
Set sht = Wb.Worksheets("光荣榜单科第一")
sht.Cells.Clear
Dim DATA_ENGINE As String
Select Case Application.Version * 1
Case Is <= 11
DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
Case Is >= 12
DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
End Select
Set cnn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
cnn.Open DATA_ENGINE & DataPath
With sht
.Cells.Clear
i = 0 '计数器
sb = Array("语文", "数学", "英语")
'先处理语数英
For Each s In sb
Sql = "select 姓名," & s & "," & s & "年级排名"
Sql = Sql & " FROM [" & DataSht.Name & "$A1:cZ] WHERE 班级=" & class & " and " & s & "班级排名=1"
Debug.Print Sql
On Error Resume Next
rs.Close
On Error GoTo 0
rs.Open Sql, cnn, 1, 3
If rs.RecordCount > 0 Then
Do
i = i + 1
.Cells((i - 1) * 3 + 1, 1).Resize(1, 4).Value = Array("科目", "姓名", "分数", "年级排名")
.Cells((i - 1) * 3 + 2, 1).Value = s
For j = 0 To rs.Fields.Count - 1
.Cells((i - 1) * 3 + 2, j + 2).Value = rs.Fields(j)
Next j
SetBordersAndCenters .Cells((i - 1) * 3 + 1, 1).CurrentRegion
rs.MoveNext
Loop Until rs.EOF
End If
Next s
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
sb = Array("物理", "历史", "化学d", "生物d", "政治d", "地理d")
'先处理语数英
For Each s In sb
Sql = "select 姓名," & s & "," & s & "科类排名"
Sql = Sql & " FROM [" & DataSht.Name & "$A1:cZ] WHERE 班级=" & class & " and " & s & "班级排名=1"
Debug.Print Sql
On Error Resume Next
rs.Close
On Error GoTo 0
rs.Open Sql, cnn, 1, 3
If rs.RecordCount > 0 Then
Do
i = i + 1
.Cells((i - 1) * 3 + 1, 1).Resize(1, 4).Value = Array("科目", "姓名", "分数", "科类排名")
.Cells((i - 1) * 3 + 2, 1).Value = s
For j = 0 To rs.Fields.Count - 1
.Cells((i - 1) * 3 + 2, j + 2).Value = rs.Fields(j)
Next j
SetBordersAndCenters .Cells((i - 1) * 3 + 1, 1).CurrentRegion
rs.MoveNext
Loop Until rs.EOF
End If
Next s
End With
rs.Close
cnn.Close
Set Wb = Nothing
Set DataSht = Nothing
Set sht = Nothing
Set cnn = Nothing
Set rs = Nothing
End Sub
进退前五
使用left join
Sub 进步前五()
'实例化对象
Set Wb = Application.ThisWorkbook
DataPath = Wb.FullName
Set DataSht = Wb.Worksheets("期中考试2")
Set DataSht2 = Wb.Worksheets("分班成绩")
Set sht = Wb.Worksheets("光荣榜进步前五")
Dim DATA_ENGINE As String
Select Case Application.Version * 1
Case Is <= 11
DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
Case Is >= 12
DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
End Select
Set cnn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
cnn.Open DATA_ENGINE & DataPath
With sht
.Cells.Clear
endrow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
Sql = "select a.姓名,a.总分d,a.总分d科类排名,a.总分d班级排名, (b.总分d科类排名-a.总分d科类排名) as 进步名次 FROM [" & DataSht.Name & "$A1:cZ] a "
Sql = Sql & " left join " & "[" & DataSht2.Name & "$A1:cZ] b on a.账号=b.考生号 WHERE a.班级=" & class & " and a.总分d<>0 order by (b.总分d科类排名-a.总分d科类排名) desc"
Debug.Print Sql
Set Rng = .Range("a2")
Set rs = cnn.Execute(Sql)
arr = WorksheetFunction.Transpose(rs.getrows)
For i = 1 To 5
.Cells((i - 1) * 3 + 1, 1).Resize(1, 5).Value = Array("姓名", "总分d", "科类排名", "班级排名", "进步名次")
Set Rng = .Cells((i - 1) * 3 + 2, 1)
Rng.Resize(1, UBound(arr, 2)).Value = WorksheetFunction.Index(arr, i)
SetBordersAndCenters Rng.CurrentRegion
Next i
End With
rs.Close
cnn.Close
Set Wb = Nothing
Set DataSht = Nothing
Set DataSht2 = Nothing
Set sht = Nothing
Set cnn = Nothing
Set rs = Nothing
Set Rng = Nothing
End Sub
粘贴到word
Sub 光荣榜转帖到文档()
Set dic = CreateObject("Scripting.Dictionary")
Dim wdApp As Object
Dim doc As Object
Dim sht As Worksheet
Dim cel As Range
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
Set doc = wdApp.documents.Add
doc.Activate
For Each sht In ThisWorkbook.Worksheets
If sht.Name Like "*光荣榜*" Then
With sht
wdApp.Selection.typetext Replace(.Name, "光荣榜", "") '类别
wdApp.Selection.typeparagraph '回车
x = 0
For Each cel In .UsedRange.Cells
If cel.Value = "姓名" Then
Key = cel.Offset(1).Value
If dic.exists(Key) = False Then dic(Key) = ""
Set Rng = cel.CurrentRegion
'SetBordersAndCenters Rng
Debug.Print Rng.Address(1, 1)
CopyAgain:
Rng.Copy
'Stop
On Error Resume Next
wdApp.Selection.PasteExcelTable False, False, False
If x >= 10 Then GoTo Ignore:
If Err.Number <> 0 Then
x = x + 1
GoTo CopyAgain
End If
Ignore:
Err.Clear
x = 0
wdApp.Selection.typeparagraph '回车
wdApp.Selection.typeparagraph '回车
End If
Next cel
End With
End If
Next sht
wdApp.Selection.typetext "拍照名单："
wdApp.Selection.typeparagraph '回车
n = 0
For Each k In dic.Keys
n = n + 1
wdApp.Selection.typetext n & "、" & k
wdApp.Selection.typetext " "
Next k
doc.SaveAs ThisWorkbook.Path & "\" & class & ".docx"
doc.Close
wdApp.Quit
Set wdApp = Nothing
Set doc = Nothing
Set Rng = Nothing
End Sub
Private Sub SetBordersAndCenters(ByVal Rng As Range)
With Rng.Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Columns.ColumnWidth = 12
End With
End Sub
标签：Set,End,rs,烦人,Sql,光荣榜,Nothing,Cells 来源： https://www.cnblogs.com/nextseven/p/16226426.html