20181013xlVba据成绩条生成图片文件

Posted 2021-01-12 nextseven

Sub CreateGoalPictures()
    ‘声明变量
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim Shp As Shape
    Dim Pic, EndRow
    Dim FilePath, StudentName
    ‘设置变量
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(1)
    
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        For i = 1 To EndRow ‘循环所有学生成绩条
        
            If .Cells(i, 2).Value = "姓名" Then
                StudentName = .Cells(i + 1, 2).Value ‘获取当前学生姓名
                FilePath = Wb.Path & "" & StudentName & ".jpg" ‘构建图片路径
                
                For Each Shp In .Shapes ‘预先删除工作表中的图形
                    Shp.Delete
                Next Shp
                
                .Cells(i, 1).CurrentRegion.Copy ‘复制学生成绩条区域
                Set Pic = .Pictures.Paste ‘选择性粘贴为图片
                
                Pic.Copy ‘复制该图片
                With .ChartObjects.Add(0, 0, Pic.Width, Pic.Height).Chart ‘新建图标
                    .Paste ‘粘贴图片
                    .Export FilePath ‘导出图片文件
                    .Parent.Delete ‘删除图表
                End With
            End If
        Next i
    End With
    
    ‘释放对象
    Set Wb = Nothing
    Set Sht = Nothing
    Set Pic = Nothing
End Sub