차트 생성 후 이미지 저장

하루하나 카페에 올라온 질문글.

학생이 300명 정도 있고 개인별로 차트 생성을 해야한다.

게다가 1인당 생성해야하는 차트는 총 두개.

작업일지는 다음과 같다.

1. 파일을 불러와서 각 시트를 순환하며 작업

2. 시트명이 과목별 시험 성적 또는 과목별 수행 등급일 때만 매크로 실행

3. 이름에 빈칸들이 있어서 밑에서 위로 올라가며 작업

4. 차트 폴더를 생성하고 각 차트들을 이미지로 저장

Option Explicit
Sub mkChart()
 
    Dim openFiles As Variant, openFile As Variant, xlsFile As String
    Dim wrkSht As Worksheet
    Dim rngArea As Range, testArea As Range
    Dim intR As Integer, intC As Integer
    Dim i As Integer, cntR As Integer
    Dim chtData As Range
    Dim strPath As String, strFile As String
    Const chtWidth As Integer = 360, chtHeight As Integer = 216
    
    '작업속도 향상
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    '파일불러오기
    xlsFile = "엑셀 파일 (*.xls*), *.xls*"
    openFiles = Application.GetOpenFilename(filefilter:=xlsFile, Title:="파일 선택", MultiSelect:=True)
    
    If IsArray(openFiles) = True Then
        
        For Each openFile In openFiles
            Workbooks.Open Filename:=openFile
            
            '과목별 시험 성적과 과목별 수행 등급 시트만 작업
            For Each wrkSht In Worksheets
                If wrkSht.Name = "과목별 시험 성적" Or wrkSht.Name = "과목별 수행 등급" Then
    
                    '이름 영역, 과목영역 설정 및 데이터 열, 행 파악
                    Set rngArea = Range("C3", Cells(Rows.Count, "C").End(xlUp)).Offset(, -1)    '이름
                    Set testArea = Range("D2", Cells(2, Columns.Count).End(xlToLeft))   '과목
                    intR = rngArea.Rows.Count   '이름 행수
                    intC = testArea.Columns.Count + 1   '과목 열수
                    cntR = 1    '개인별 데이터영역
                    strPath = ThisWorkbook.Path & "\" & wrkSht.Name & "\" '파일저장 경로
 
                    '이름영역의 마지막에서 처음으로 역으로 올라오며 작업(빈셀 때문)
                    For i = intR + 2 To 3 Step -1
        
                        '이름셀이 빈칸일 경우 학생별 행수를 1씩 늘려감
                        If Cells(i, "B") = "" Then cntR = cntR + 1
        
                        '이름셀에 값이 있을 경우
                        If Cells(i, "B") <> "" Then
        
                            '파일명 및 차트 영역 설정
                            strFile = strPath & Range("A1") & "-" & Cells(i, "B") & ".jpg"
                            Set chtData = Cells(i, "C").Resize(cntR, intC)
            
                            '차트 생성 후 서식 설정
                            ActiveSheet.Shapes.AddChart(Width:=chtWidth, Height:=chtHeight).Select
            
                            With ActiveChart
                                .SetSourceData Source:=chtData  '차트 소스
                                .ChartType = xlColumnClustered  '세로막대형 차트
                                .PlotBy = xlRows    '행방향으로 차트 설정
                                .Axes(Type:=xlCategory).CategoryNames = testArea 'X축 레이블은 과목명
                                .SetElement msoElementChartTitleAboveChart  '차트 위쪽에 제목 표시
                        
                                '차트 제목 서식
                                With .ChartTitle
                                    .Text = Cells(i, "B")
                                    .Format.TextFrame2.TextRange.Font.Size = 14
                                End With
                
                                'Chart 폴더 생성하고 기존 파일이 있는지 파악 후 이미지로 차트저장하고 차트 삭제
                                If Dir(strPath, vbDirectory) = "" Then MkDir strPath
                                If Dir(strFile) <> "" Then Kill pathname:=strFile
                                .Export Filename:=strFile, filtername:="JPG"
                                .Parent.Delete
                            End With
            
                            '개인별 데이터영역 초기화
                            cntR = 1
                        End If
                    Next i
                End If
            Next wrkSht
            
            '작업한 파일은 닫고 다음 파일 작업
            ActiveWorkbook.Close SaveChanges:=False
        Next openFile
        
        MsgBox "작업을 완료하였습니다."
    
    '파일을 선택하지 않으면 매크로 종료
    Else
        Exit Sub
    End If
    
    '작업속도 복구
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
End Sub

+ 반별 차트 +

+ 매크로 실행 후 폴더생성 화면 +

+ 개인별 차트 이미지 생성 결과 +

차트만들기.xlsm

A반.xlsx