Export each row as separate image of a selected range in VBA

[mehidy1437]

Hi Guys,
I want to export each row of my selection range as separate image in VBA.
Image name will be from the first column data.
Like as, S1001.jpg, S1002.jpg & go on.

Is it possible?
If yes, give me some idea with the code.

 

[jkpieterse]

A solution would be to make sure the macro copies "Range2Export" as a picture and pastes that range on top of the chart and then exports the chart. I don't have time to write that code now though.

 

[Rick Rothstein]

Does this code work for you (change the directory location, I used "c:\temp\", in the export statement to the directory where you want to store the pictures)...

Sub CopyDataRowsAsJPGs()
  Dim R As Long, Wdth As Double, Hght As Double, Pict As Variant, Cht As ChartObject
  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    With Cells(R, "A").Resize(, 4)
      .CopyPicture xlScreen, xlPicture
      Wdth = .Width
      Hght = .Height
    End With
    Set Cht = ActiveSheet.ChartObjects.Add(0, 0, Wdth, Hght)
    Cht.Activate
    With ActiveChart
      .Paste
      .Export Filename:="c:\temp\" & Cells(R, "A").Value & ".jpg", Filtername:="JPG"
    End With
    Cht.Delete
  Next
End Sub

 

[jkpieterse]

Thanks Rick

 

[mehidy1437]

Hi Rick



Many thanks , it’s working.

But sometimes some row is coming as blank without any data.

1st time it was blank for two row, 2nd time it was blank for 1 row.



I want 1st row all title to be include in each picture.

Kindly advise.

 

[Rick Rothstein]

Many thanks , it’s working.

But sometimes some row is coming as blank without any data.

1st time it was blank for two row, 2nd time it was blank for 1 row.

I am not sure what to tell you as this does not happen for me in my tests.

I want 1st row all title to be include in each picture.

Give this modified version of my code a try...

Sub CopyDataRowsAsJPGs()
  Dim R As Long, Wdth As Double, Hght As Double, Pict As Variant, Cht As ChartObject
  Application.ScreenUpdating = False
  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    With Range("A1:D1", Cells(R, "A").Resize(, 4))
      If R > 2 Then Rows("2:" & R - 1).Hidden = True
      .CopyPicture xlScreen, xlPicture
      Wdth = .Width
      Hght = .Height
    End With
    Set Cht = ActiveSheet.ChartObjects.Add(0, 0, Wdth, Hght)
    Cht.Activate
    With ActiveChart
      .Paste
      .Export Filename:="c:\temp\" & Cells(R, "A").Value & ".jpg", Filtername:="JPG"
    End With
    Cht.Delete
  Next
  Rows.Hidden = False
  Application.ScreenUpdating = True
End Sub

 

[mehidy1437]

Many many thanks. It's working.
Just having two issue, if cell contain any formula, even if there is any simple formula, its not complete all the row.

But if there is no formula & have only values, then it miss at least one row. I have tried with 20 row.
Here below the snap for your ref.

 

[Rick Rothstein]

Just having two issue, if cell contain any formula, even if there is any simple formula, its not complete all the row.

But if there is no formula & have only values, then it miss at least one row. I have tried with 20 row.

I have tried several times with varying number of rows with and without formulas and cannot duplicate the problem you are reporting. Unfortunately, given that, I do not know what to tell you. Sorry.

 

[mehidy1437]

Dear Rick, thank you very much for what you did.
It might be a problem due to other reason.