I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ?
Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.
Assuming that you put your files in "Files" directory relative to your master workbook your code might look like this:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
In this example DoWork() is your macro that you apply to all of your files. Make sure that you do all your processing in your macro is always in the context of the wb (currently opened workbook).
Disclaimer: all possible error handling skipped for brevity.
A part of the question might be how do I run this on 1000 files?... Do I have to add this macro to all 1000 workbooks?
One way to do this is to add your macro's centrally to the file PERSONAL.XLSB (sometimes the extension might be different). This file will be loaded in the background every time you start Excel and makes your macro's available at any time.
Initially the PERSONAL.XLSB file will NOT be there. To automatically create this file, just start recording a "dummy" macro (with the record button on the left-bottom of a spreadsheet) and select "Personal Macro Workbook" to store it in.
After recording your macro, you can open the VBA editor with Alt+F11 and you will see the PERSONAL.XLSB file with the "dummy" recorded macro.
I use this file to store loads of general macro's which are always available, independent of which .xlsx file I have open. I have added these macro's to my own menu ribbon.
One disadvantage of this common macro file is that if you launch more than one instance of Excel, you will get an error message that the PERSONAL.XLSB file is already in use by Excel instance Nr. 1. This is no problem as long as you do not add new macro's at this moment.
Thank you very much for this
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
BSAQmacro wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
While running this code its showing bad file name or number.
i have stored my all file in ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder
Instead of passing the values to DoWork one can also run the jobs in Processfiles().
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Dim Counter As Integer
Set wb1 = ActiveWorkbook
Set PasteStart = [RRimport!A1]
Pathname = ActiveWorkbook.Path & "\For Macro to run\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb2 = Workbooks.Open(Pathname & Filename)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
wb2.Close
Filename = Dir()
Loop
End Sub
This isn't an exact answer to the question, since I was just trying to run a single script on any file that I opened and couldn't get that to work, but I thought this might help others like me. It worked once I moved the code into a Module in the Visual Basic for Applications dialog box (go to "Insert" then "Module"). Once I added my VBA code to a module, I was able to open any other file in Excel (even a CSV file) and go to Macros, and run the Macro from the other file (that contains the Module with the code) on the file that I had open.
Thanks Peterm!!
Actually, I did my macro using exactly the same code you posted (process_fiels and dowork).
It worked brilliant!! (before my question)
Each of my 1000 workbooks has 84 worksheets. My own macro (which finally works!) splits each workbook into 85 different files (the original + a short version of each worksheet saved as an individual file).
That leaves me with 1000 files + 1000x85 in the same folder, and that would be really hard to sort out.
What I really need is for Process_Files to take the first file, create a folder with the name of the first file, move the first file to the folder with ist name, then run my macro (in the folder named after the first file in the newly created folder...), go back and take the second file, create a folder with the name of the second file, move the second file to the folder with ist name, then run my macro (in the folder named after the second file in the newly created folder...), etc...
At the end, I should have moved all files into folders with the same name as the files, and the contents of the original \Files\ folder would be 1000 folders with the name of the original files, containgin the original files + 84 files which my own macro already does.
Maybe it is easier with the code:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
(Here, it should read the file name, create a folder with the file name, move the file into this newly created folder)
Set wb = Workbooks.Open(Pathname & Filename) <- open file, just as is.
DoWork wb <- do my macro,just as is
wb.Close SaveChanges:=False <- not save, to keep the original file
(go back to the original \Files\ folder)
Filename = Dir() <- Next file, just as is
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
MyMacro
End With
End Sub
Many thanks, this site is great!
__________________edit, the macro now works _________________________
As you can see, I am no VBA expert, but the macro finally works. The code is not neat at all, I am no SW programmer.
Here it is, it might help some one some day.
Sub ProcessFiles_All()
Dim Filename, Pathname, NewPath, FileSource, FileDestination As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.csv")
Do While Filename <> ""
NewPath = Pathname & Left(Filename, 34) & "\"
On Error Resume Next
MkDir (NewPath)
On Error GoTo 0
Set wb = Workbooks.Open(Pathname & Filename)
DoWorkPlease wb ' <------------ It is important to say please!!
On Error Resume Next
wb.Close SaveChanges:=False
if Err.Number <> 0 then
‘Error handler needed here
End if
Filename = Dir()
Loop
End Sub
Sub DoWorkPlease(wb As Workbook)
With wb
‘ Since my application has over 1800 cells for each column and it is time consuming
‘ I use a “testing mode” were I only play with 18 values.
Dim TestingMode As Integer
Dim ThisRange(1 To 4) As Variant
TestingMode = 0
If TestingMode = 1 Then
ThisRange(1) = "B2:CG18"
ThisRange(2) = "CT2:CT18"
ThisRange(3) = "CH2:CN18"
ThisRange(4) = "CN2:CS18"
Rows("19:18201").Select
Selection.Delete Shift:=xlUp
End If
If TestingMode = 0 Then
ThisRange(1) = "B2:CG18201"
ThisRange(2) = "CT2:CT18201"
ThisRange(3) = "CH2:CN18201"
ThisRange(4) = "CN2:CS18201"
End If
‘ speed up the macro, turn off updating and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
‘ Here is my code that manipulates the cell values from digits (values read by sensors need to be “translated” into real world values. Code not here actually.
‘Then I copy the whole thing into just numbers, there are no longer formulas, easier to work this way.
'_____________________________________
'Get just values - no more formulas
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet1").Select
Columns("A:CT").Select
Selection.Copy
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
‘ Then I save this new workbook into a folder with its own name (and under the folder \FILES\
'_____________________________________
'Save the work under its own folder
Dim CleanName, CleanPath, CleanNewName As Variant
CleanPath = ActiveWorkbook.Path
CleanName = ActiveWorkbook.Name
CleanName = Left(CleanName, 34) ‘I take out the extension
CleanPath = CleanPath + "\" + CleanName
CleanNewName = CleanPath + "\" + CleanName
CleanNewName = CleanNewName + "_clean.csv" ‘ and I add “clean” to have a different name now.
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False
‘If there is an error I create an empty folder with the name of the file to know which file needs rework.
If Err.Number <> 0 Then
MkDir (CleanPath + "_error_" + CleanName)
End If
'Resume Next
ActiveSheet.Move _
After:=ActiveWorkbook.Sheets(1)
‘ Then I split the workbook into individual files with the data I need for individual sensors.
‘ Here are the individual ranges I need for each file. Since I have over 1000 files, it is worth the effort.
'_______________ the Split!!______________________________
Dim Col(1 To 98) As Variant
Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT"
Col(2) = "A:A,C:C,CH:CH,CN:CN,CT:CT"
Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT"
Col(4) = "A:A,E:E,CH:CH,CN:CN,CT:CT"
Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT"
Col(6) = "A:A,G:G,CH:CH,CN:CN,CT:CT"
Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT"
Col(8) = "A:A,I:I,CH:CH,CN:CN,CT:CT"
Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT"
Col(10) = "A:A,K:K,CH:CH,CN:CN,CT:CT"
Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT"
Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT"
Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT"
Col(14) = "A:A,O:O,CH:CH,CN:CN,CT:CT"
Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT"
Col(16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT"
Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT"
Col(18) = "A:A,S:S,CI:CI,CO:CO,CT:CT"
Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT"
Col(20) = "A:A,U:U,CI:CI,CO:CO,CT:CT"
Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT"
Col(22) = "A:A,W:W,CI:CI,CO:CO,CT:CT"
Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT"
Col(24) = "A:A,Y:Y,CI:CI,CO:CO,CT:CT"
Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT"
Col(26) = "A:A,AA:AA,CI:CI,CO:CO,CT:CT"
Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT"
Col(28) = "A:A,AC:AC,CI:CI,CO:CO,CT:CT"
Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT"
Col(30) = "A:A,AE:AE,CJ:CJ,CP:CP,CT:CT"
Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT"
Col(32) = "A:A,AG:AG,CJ:CJ,CP:CP,CT:CT"
Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT"
Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT:CT"
Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT"
Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP,CT:CT"
Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT"
Col(38) = "A:A,AM:AM,CJ:CJ,CP:CP,CT:CT"
Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT"
Col(40) = "A:A,AO:AO,CJ:CJ,CP:CP,CT:CT"
Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT"
Col(42) = "A:A,AQ:AQ,CJ:CJ,CP:CP,CT:CT"
Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT"
Col(44) = "A:A,AS:AS,CK:CK,CQ:CQ,CT:CT"
Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT"
Col(46) = "A:A,AU:AU,CK:CK,CQ:CQ,CT:CT"
Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT"
Col(48) = "A:A,AW:AW,CK:CK,CQ:CQ,CT:CT"
Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT"
Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ,CT:CT"
Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT"
Col(52) = "A:A,BA:BA,CK:CK,CQ:CQ,CT:CT"
Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT"
Col(54) = "A:A,BC:BC,CK:CK,CQ:CQ,CT:CT"
Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT"
Col(56) = "A:A,BE:BE,CK:CK,CQ:CQ,CT:CT"
Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT"
Col(58) = "A:A,BG:BG,CL:CL,CR:CR,CT:CT"
Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT"
Col(60) = "A:A,BI:BI,CL:CL,CR:CR,CT:CT"
Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT"
Col(62) = "A:A,BK:BK,CL:CL,CR:CR,CT:CT"
Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT"
Col(64) = "A:A,BM:BM,CL:CL,CR:CR,CT:CT"
Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT"
Col(66) = "A:A,BO:BO,CL:CL,CR:CR,CT:CT"
Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT"
Col(68) = "A:A,BQ:BQ,CL:CL,CR:CR,CT:CT"
Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT"
Col(70) = "A:A,BS:BS,CL:CL,CR:CR,CT:CT"
Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT"
Col(72) = "A:A,BU:BU,CM:CM,CS:CS,CT:CT"
Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT"
Col(74) = "A:A,BW:BW,CM:CM,CS:CS,CT:CT"
Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT"
Col(76) = "A:A,BY:BY,CM:CM,CS:CS,CT:CT"
Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT"
Col(78) = "A:A,CA:CA,CM:CM,CS:CS,CT:CT"
Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT"
Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT"
Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT"
Col(82) = "A:A,CE:CE,CM:CM,CS:CS,CT:CT"
Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT"
Col(84) = "A:A,CG:CG,CM:CM,CS:CS,CT:CT"
‘ I want to split 84 new files, so for testing I use only 1, and for the real thing I go with 84
Dim CounterMode As Integer
If TestingMode = 1 Then CounterMode = 1 Else CounterMode = 84
For i = 1 To CounterMode
‘ this code takes the columns need, and paste it into a new workbook.
Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents
Range("A1").Activate
Sheets(2).Select
Range(Col(i)).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:E").EntireColumn.AutoFit
‘ Save the individual file
'_____________save the work________________
Dim ThePath, TheName, TheSwitch As String
ThePath = ActiveWorkbook.Path + “\”
TheName = Left(ActiveWorkbook.Name, 34) ‘ take out the extension from the name
ThePath = ThePath + TheName
TheSwitch = Cells(3, 2) ‘ In Cell (3,2) I have the name of the individual name, so I added to the file name.
TheName = ThePath + "_" + TheSwitch + ".xls"
Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
Dim SheetName As Variant
‘ I name Sheets(1) as Sheet1, since the original sheet has the name and date of the test.
‘ I do this to have the same name on all file in order to do a plot, then I rename the sheet with the
‘ original name
SheetName = ActiveSheet.Name
ActiveWorkbook.Sheets(1).Name = "Sheet1"
‘ here is the plot
Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
ActiveWorkbook.Sheets(1).Name = SheetName
‘save
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False
If Err.Number <> 0 Then
MkDir (ThePath + "_error_" + TheName)
End If
ActiveWorkbook.Close
Next i
'____________________That was the Split__________________________________
' Turn on screenupdating:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A1").Select
End With
End Sub
Please suggest the better way of exporting range of data from excel worksheets as image either in .jpeg or .png or in .gif.
do you want to try the below code I found on the internet somewhere many moons ago and used.
It uses the Export function of the Chart object along with the CopyPicture method of the Range object.
References:
MSDN - Export method as it applies to the Chart object. to save the clipboard as an Image
MSDN - CopyPicture method as it applies to the Range object to copy the range as a picture
dim sSheetName as string
dim oRangeToCopy as range
Dim oCht As Chart
sSheetName ="Sheet1" ' worksheet to work on
set oRangeToCopy =Range("B2:H8") ' range to be copied
Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap
set oCht =charts.add
with oCht
.paste
.Export FileName:="C:\SavedRange.jpg", Filtername:="JPG"
end with
I've tried to improve this solution in several ways. Now resulting image has right proportions.
Set sheet = ActiveSheet
output = "D:\SavedRange4.png"
zoom_coef = 100 / sheet.Parent.Windows(1).Zoom
Set area = sheet.Range(sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export output, "png"
chartobj.Delete
Thanks everyone! I modified Winand's code slightly to export it to the user's desktop, no matter who is using the worksheet. I gave credit in the code to where I got the idea (thanks Kyle).
Sub ExportImage()
Dim sFilePath As String
Dim sView As String
'Captures current window view
sView = ActiveWindow.View
'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView
'Temporarily disable screen updating
Application.ScreenUpdating = False
Set Sheet = ActiveSheet
'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"
'Export print area as correctly scaled PNG image, courtasy of Winand
zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete
'Returns to the previous view
ActiveWindow.View = sView
'Re-enables screen updating
Application.ScreenUpdating = True
'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here:" & Chr(10) & Chr(10) & sFilePath)
End Sub
Winand, Quality was also an issue for me so I did this:
For Each ws In ActiveWorkbook.Worksheets
If ws.PageSetup.PrintArea <> "" Then
'Reverse the effects of page zoom on the exported image
zoom_coef = 100 / ws.Parent.Windows(1).Zoom
areas = Split(ws.PageSetup.PrintArea, ",")
areaNo = 0
For Each a In areas
Set area = ws.Range(a)
' Change xlPrinter to xlScreen to see zooming white space
area.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set chartobj = ws.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
'scale the image before export
ws.Shapes(chartobj.Index).ScaleHeight 3, msoFalse, msoScaleFromTopLeft
ws.Shapes(chartobj.Index).ScaleWidth 3, msoFalse, msoScaleFromTopLeft
chartobj.Chart.Export ws.Name & "-" & areaNo & ".png", "png"
chartobj.delete
areaNo = areaNo + 1
Next
End If
Next
See here:https://robp30.wordpress.com/2012/01/11/improving-the-quality-of-excel-image-export/
Solution without charts
Function SelectionToPicture(nome)
'save location ( change if you want )
FName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & nome & ".jpg"
'copy selection and get size
Selection.CopyPicture xlScreen, xlBitmap
w = Selection.Width
h = Selection.Height
With ThisWorkbook.ActiveSheet
.Activate
Dim chtObj As ChartObject
Set chtObj = .ChartObjects.Add(100, 30, 400, 250)
chtObj.Name = "TemporaryPictureChart"
'resize obj to picture size
chtObj.Width = w
chtObj.Height = h
ActiveSheet.ChartObjects("TemporaryPictureChart").Activate
ActiveChart.Paste
ActiveChart.Export FileName:=FName, FilterName:="jpg"
chtObj.Delete
End With
End Function
If you add a Selection and saving to workbook path to Ryan Bradley code that will be more elastic:
Sub ExportImage()
Dim sheet, zoom_coef, area, chartobj
Dim sFilePath As String
Dim sView As String
'Captures current window view
sView = ActiveWindow.View
'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView
'Temporarily disable screen updating
Application.ScreenUpdating = False
Set sheet = ActiveSheet
'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
'sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"
'##################
'Łukasz : Save to workbook directory
'Asking for filename insted of ActiveSheet.Name is also good idea, without file extension
dim FileID as string
FileID=inputbox("Type a file name","Filename...?",ActiveSheet.Name)
sFilePath = ThisWorkbook.Path & "\" & FileID & ".png"
'Łukasz:Change code to use Selection
'Simply select what you want to export and run the macro
'ActiveCell should be: Top Left
'it means select from top left corner to right bottom corner
Dim r As Long, c As Integer, ar As Long, ac As Integer
r = Selection.rows.Count
c = Selection.Columns.Count
ar = ActiveCell.Row
ac = ActiveCell.Column
ActiveSheet.PageSetup.PrintArea = Range(Cells(ar, ac), Cells(ar, ac)).Resize(r, c).Address
'Export print area as correctly scaled PNG image, courtasy of Winand
'Łukasz: zoom_coef can be constant = 0 to 5 can work too, but save is 0 to 4
zoom_coef = 5 '100 / sheet.Parent.Windows(1).Zoom
'#############
Set area = sheet.Range(sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter 'xlBitmap '
Set chartobj = sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete
'Returns to the previous view
ActiveWindow.View = sView
'Re-enables screen updating
Application.ScreenUpdating = True
'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here: :" & Chr(10) & Chr(10) & sFilePath)
'Close
End Sub
This gives me the most reliable results:
Sub RangeToPicture()
Dim FileName As String: FileName = "C:\file.bmp"
Dim rPrt As Range: Set rPrt = ThisWorkbook.Sheets("Sheet1").Range("A1:C6")
'Add a Zoom to increase the resolution of the image.
ActiveWindow.Zoom = 300
Dim chtObj As ChartObject
rPrt.CopyPicture xlScreen, xlBitmap
Set chtObj = ActiveSheet.ChartObjects.Add(1, 1, rPrt.Width, rPrt.Height)
chtObj.Activate
ActiveChart.Paste
ActiveChart.Export FileName
chtObj.Delete
'Reset Zoom to innitial zoom of the image.
ActiveWindow.Zoom = 100
End Sub
Based on the link provided by Philip I got this to working
Worksheets("Final Analysis Sheet").Range("A4:G112").CopyPicture xlScreen, xlBitmap
Application.DisplayAlerts = False
Set oCht = Charts.Add
With oCht
.Paste
.Export Filename:="C:\FTPDailycheck\TodaysImages\SavedRange.jpg", Filtername:="JPG"
.Delete
End With
There's a more direct way to export a range image to a file, without the need to create a temporary chart. It makes use of PowerShell to save the clipboard as a .png file.
Copying the range to the clipboard as an image is straightforward, using the vba CopyPicture command, as shown in some of the other answers.
A PowerShell script to save the clipboard requires only two lines, as noted by thom schumacher in Save Image from clipboard using PowerShell.
VBA can launch a PowerShell script and wait for it to complete, as noted by Asam in Wait for shell command to complete.
Putting these ideas together, we get the following routine. I've tested this only under Windows 10 using the Office 2010 version of Excel. Note that there's an internal constant AidDebugging which can be set to True to provide additional feedback about the execution of the routine.
Option Explicit
' This routine copies the bitmap image of a range of cells to a .png file.
' Input arguments:
' RangeRef -- the range to be copied. This must be passed as a range object, not as the name
' or address of the range.
' Destination -- the name (including path if necessary) of the file to be created, ending in
' the extension ".png". It will be overwritten without warning if it exists.
' TempFile -- the name (including path if necessary) of a temporary script file which will be
' created and destroyed. If this is not supplied, file "RangeToPNG.ps1" will be
' created in the default folder. If AidDebugging is set to True, then this file
' will not be deleted, so it can be inspected for debugging.
' If the PowerShell script file cannot be launched, then this routine will display an error message.
' However, if the script can be launched but cannot create the resulting file, this script cannot
' detect that. To diagnose the problem, change AidDebugging from False to True and inspect the
' PowerShell output, which will remain in view until you close its window.
Public Sub RangeToPNG(RangeRef As Range, Destination As String, _
Optional TempFile As String = "RangeToPNG.ps1")
Dim WSH As Object
Dim PSCommand As String
Dim WindowStyle As Integer
Dim ErrorCode As Integer
Const WaitOnReturn = True
Const AidDebugging = False ' provide extra feedback about this routine's execution
' Create a little PowerShell script to save the clipboard as a .png file
' The script is based on a version found on September 13, 2020 at
' https://stackoverflow.com/questions/55215482/save-image-from-clipboard-using-powershell
Open TempFile For Output As #1
If (AidDebugging) Then ' output some extra feedback
Print #1, "Set-PSDebug -Trace 1" ' optional -- aids debugging
End If
Print #1, "$img = get-clipboard -format image"
Print #1, "$img.save(""" & Destination & """)"
If (AidDebugging) Then ' leave the PowerShell execution record on the screen for review
Print #1, "Read-Host -Prompt ""Press <Enter> to continue"" "
WindowStyle = 1 ' display window to aid debugging
Else
WindowStyle = 0 ' hide window
End If
Close #1
' Copy the desired range of cells to the clipboard as a bitmap image
RangeRef.CopyPicture xlScreen, xlBitmap
' Execute the PowerShell script
PSCommand = "POWERSHELL.exe -ExecutionPolicy Bypass -file """ & TempFile & """ "
Set WSH = VBA.CreateObject("WScript.Shell")
ErrorCode = WSH.Run(PSCommand, WindowStyle, WaitOnReturn)
If (ErrorCode <> 0) Then
MsgBox "The attempt to run a PowerShell script to save a range " & _
"as a .png file failed -- error code " & ErrorCode
End If
If (Not AidDebugging) Then
' Delete the script file, unless it might be useful for debugging
Kill TempFile
End If
End Sub
' Here's an example which tests the routine above.
Sub Test()
RangeToPNG Worksheets("Sheet1").Range("A1:F13"), "E:\Temp\ExportTest.png"
End Sub