Excel VBA the code failed to export pictures after the 20-22nd time export

user_16220412 0
Viewed 55

I'm trying to make the excel macro that save a batch of NIPT result files on another sheet to image files. The code for export single image is taken at https://www.mrexcel.com/board/threads/vba-to-save-range-as-png-or-jpeg.1139047/post-5515609, with extra codes to make the automation process

Sub SaveAsJPG_Batch()
    Set wbchinh_sheet = ThisWorkbook.Sheets("Raw")
    Set wbin_batch = ThisWorkbook.Sheets("In_batch")
    wbchinh_sheet_lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    wbin_batch.Activate
    wbin_batch.Range("I2").Value = Worksheets("In").Range("I2").Value
        
    x = 2
    While x <= wbchinh_sheet_lastrow
        wbin_batch.Range("H1").Value = wbchinh_sheet.Range("B" & x).Value
        wbin_batch.Range("F4").Value = x
   'Print in batch
        x = x + 1
        Application.Wait (Now + TimeValue("0:00:2"))
        With ActiveSheet
            Set CopyRange = wbin_batch.Range("A1:E34")
            If Not CopyRange Is Nothing Then
                Application.ScreenUpdating = False
                ExportName = wbin_batch.Range("I2") & "\" & wbin_batch.Range("E1") & ".jpg"
                If Not ExportName = "False" Then
                    CopyRange.Copy
                    .Pictures.Paste
                    Set Pic = .Pictures(.Pictures.Count)
                    Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
                    Application.CutCopyMode = False
                    Do
                        DoEvents
                        Pic.Copy
                        DoEvents
                        ChO.Chart.Paste
                        DoEvents
                        i = i + 1
                    Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)
    
                    ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
                    ChO.Delete
                    Pic.Delete
                End If
                Application.ScreenUpdating = True
            End If
        End With
    Wend
End Sub

When the macro activated, it scan for sheet Raw and find the last not empty line, then proceed to place each name from cell B2 to the last cell of the B column that contains the ID. After insert the name to H1 cell on In_batch sheet, the export macro will export the range from A1 to E34 to jpg file. However, during testing I find out that from 20th to 22nd image (looks like its randomly), all images after that are blank image, no table are printed and even adding pause time not solve the problem.

vba excel
1 Answers

I just found out why the script stopped working after image 20 to 22, its because i > 50. So I reset the count of i after finished my job

Sub SaveAsJPG_Batch()
    Dim x As Integer
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
    
    
    Set wbchinh_sheet = ThisWorkbook.Sheets("Raw")
    Set wbin_batch = ThisWorkbook.Sheets("In_batch")
    wbchinh_sheet_lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    wbin_batch.Activate
    wbin_batch.Range("I2").Value = Worksheets("In").Range("I2").Value
        
    x = 2
    While x <= wbchinh_sheet_lastrow
        wbin_batch.Range("H1").Value = wbchinh_sheet.Range("B" & x).Value
        wbin_batch.Range("F4").Value = x
   'Print in batch
        x = x + 1
        i = 0
        If Not wbin_batch.Range("H1").Value = "" Then
            With wbin_batch
                wbin_batch.Range("F5").Value = i
                Set CopyRange = wbin_batch.Range("A1:E34")
                Application.ScreenUpdating = False
                ExportName = wbin_batch.Range("I2") & "\" & wbin_batch.Range("E1") & ".jpg"
    
                CopyRange.Copy
                .Pictures.Paste
                Set Pic = .Pictures(.Pictures.Count)
                Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
                Application.CutCopyMode = False
                Do
                    DoEvents
                    Pic.Copy
                    DoEvents
                    ChO.Chart.Paste
                    DoEvents
                    i = i + 1
                Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)
                
                ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
                ChO.Delete
                Pic.Delete
                Application.ScreenUpdating = True
                
                Application.Wait (Now + TimeValue("0:00:1"))
            End With
        End If
    Wend
End Sub
user_162204120
Related