生成并导出成绩条图片

daly3721

Sub 生成并导出成绩条图片()
Dim i&, sht As Worksheet, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' On Error Resume Next
'''''''''''''''''''''''''''''''''''''''''''
''''''''''生成成绩条
BJarry = Array("15", "16")
For m = 0 To UBound(BJarry)
Set Sh = ThisWorkbook.Sheets(BJarry(m))
Set Rng = Sh.Range("a1").CurrentRegion
Sheets("临时").Cells.Clear
Rng.Copy Sheets("临时").Range("a1")
With Sheets("临时")
For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
.Rows("1:1").Copy
.Rows(i).Insert Shift:=xlDown
.Rows(i).Insert Shift:=xlDown
Next
.PageSetup.Orientation = xlLandscape
End With
''''''''''''''''''''''''''''''''''''''''''''''
''''''''''生成成绩条ending''''''''''''''''

''''''''''''''''''导出为图片()
     '声明变量
    Dim Shp As Shape
    Dim EndRow
    Dim FilePath, StudentName
    '设置变量
  Set sht = ThisWorkbook.Sheets("临时")
    With sht
     For Each Shp In .Shapes '预先删除工作表中的图形
        Shp.Delete
     Next Shp
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 1
        For i = 1 To EndRow
            If .Cells(i, 2).Value = "姓名" Then
                StudentName = .Cells(i + 1, 2).Value '获取当前学生姓名
                FilePath = ThisWorkbook.Path & "\" & BJarry(m) & "-成绩条图片\" & StudentName & ".jpg" '构建图片路径
                 sht.Select
                .Range(.Cells(i, 1), .Cells(i + 1, 5)).Select
                '.Cells(i, 1).Resize(2, 4).Select
                 Selection.Copy '复制学生成绩条区域
                 Selection.CopyPicture
                 With .ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart    '新建图标
                      .ChartArea.Border.LineStyle = 0 '去除边框
                      .Parent.Select
                      .Paste
                     .Export FilePath '导出图片文件
                     .Parent.Delete '删除图表
                 End With
            End If
       Next i
    End With

    '释放对象
    Set Wb = Nothing
    Set sht = Nothing
    Set Pic = Nothing
'''''''''''''''''''''''''''''''''''''''''''导出为图片
Next m
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub 导出为图片()
' On Error Resume Next
    '声明变量
    Dim Wb As Workbook
    Dim sht As Worksheet
    Dim Shp As Shape
    Dim EndRow
    Dim FilePath, StudentName
    '设置变量
Set Wb = Application.ThisWorkbook
     ' Set sht = Wb.Worksheets(1)
  Set sht = Wb.Worksheets("临时")
    With sht
     For Each Shp In .Shapes '预先删除工作表中的图形
        Shp.Delete
     Next Shp

        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 1
        For i = 1 To EndRow
            If .Cells(i, 2).Value = "姓名" Then
                StudentName = .Cells(i + 1, 2).Value '获取当前学生姓名
                FilePath = Wb.Path & "\16-成绩条图片\" & StudentName & ".jpg" '构建图片路径
                .Range(Cells(i, 1), Cells(i + 1, 5)).Select
                '.Cells(i, 1).Resize(2, 4).Select
                 Selection.Copy '复制学生成绩条区域
                 Selection.CopyPicture
                 With .ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart    '新建图标
                      .ChartArea.Border.LineStyle = 0 '去除边框
                      .Parent.Select
                      .Paste
                     .Export FilePath '导出图片文件
                     .Parent.Delete '删除图表
                 End With
            End If
       Next i
    End With

    '释放对象
    Set Wb = Nothing
    Set sht = Nothing
    Set Pic = Nothing
End Sub
Sub 成绩条()
Dim i&, sht As Worksheet, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Rng = Sheet1.Range("a1").CurrentRegion
Sheets("成绩条").Cells.Clear
Rng.Copy Sheets("成绩条").Range("a1")
With Sheets("成绩条")
For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
.Rows("1:1").Copy
.Rows(i).Insert Shift:=xlDown
.Rows(i).Insert Shift:=xlDown
Next
.PageSetup.Orientation = xlLandscape
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub