烦人的光荣榜

广告公司说不会从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