I am trying to save a range as a picture file. The code below (scraped from another post) works, but I don't want to create a chart page which I then need to delete. Any suggestions?
Sub savedeal()
Dim sSheetName As String
Dim oRangeToCopy As Range
Dim oCht As Chart
Dim myFileName As String, myPath As String
myFileName = Format(Now(), "dd-mmm-yy") & "-" & "DEAL.PNG"
myPath = "D:\Hughs Files\Google Drive\Work Folder\Polaris\Blog\"
Worksheets("BOOK").Range("B15:M45").CopyPicture xlScreen, xlBitmap
Set oCht = Charts.Add
With oCht
.Export Filename:=myPath & "\" & myFileName, Filtername:="PNG"
End With
End Sub
This has been discussed for years, if you want it saved as an image you will have to add a chart, even add-ins use a chart.
One thing you can do though is save the desired range as a PDF for example.
Sub RngToPDF()
Dim sh As Worksheet, rng As Range, Fnm As String
Set sh = Sheets("Book")
Set rng = sh.Range("B15:M45")
Fnm = "C:\Users\Dave\Downloads\TestMe.pdf"
With sh.PageSetup
.PrintArea = rng.Address
.PrintGridlines = True
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fnm
End Sub
Related
I have the below code which runs through as expected for the word creation when I add in the section for save to pdf it runs and saves the first time through. The second loop it builds the word file and saves the file but fails to complete the pdf creation a second time round. I get the following error after the second word file has finished in the loop.
Run time error '462'
The remote server machine does not exist or is not available
Quite new to VBA so be gentle with my code!!
Thanks in advance,
David
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Do Until FilterValue = 0
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
Set WdApp = CreateObject("Word.Application")
With WdApp
.Visible = True
.Activate
.Documents.Add "C:\Users\david\Documents\Custom Office Templates\IBD Registry Quarterly Report Template2.dotx"
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
.Selection.GoTo what:=-1, Name:="TableLocation"
.Selection.Paste
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
Sheets("Static").Select
Sheets("Static").Activate
Organisation = Range("D2").Value
Sheets("Static").Select
Range("D2").Copy
.Selection.GoTo what:=-1, Name:="Organisation"
.Selection.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
Sheets("Static").Select
Range("F2").Copy
.Selection.GoTo what:=-1, Name:="MalePatients"
.Selection.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
Chart2.ChartArea.Copy
.Selection.GoTo what:=-1, Name:="ChartLocation"
.Selection.Paste
If .Version <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & FileExt
If .Version <= 12 Then
.ActiveDocument.SaveAs SaveName
Else
.ActiveDocument.SaveAs2 SaveName
End If
SaveNamePDF = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & ".pdf"
ActiveDocument.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
.ActiveDocument.Close
.Quit
End With
Set WdApp = Nothing
FilterValue = FilterValue - 1
Application.DisplayAlerts = False
Sheets("Static").Delete
Application.DisplayAlerts = True
Loop
End Sub
As #BigBen pointed out you have some commands inside your loop that should be outside it. I have rewritten your code to show you how you can some additional improvements that will help optimize your code.
VBA code runs more quickly if you avoid selecting things. This applies equally to Excel and Word. Both applications have Range objects that can be used in place of Selection.
You also have an undeclared variable in your code, Row, so you should add that to your variable declarations, (preferably using a different name though as Row is an object in Excel and confusion can occur when variables have the same name). You can avoid these issues by adding Option Explicit at the top of the code module. This will prevent your code from compiling when you have undeclared variables. To add this automatically to new modules open the VBE and go to Tools | Options. In the Options dialog ensure that Require Variable Declaration is checked.
On the whole though it's not a bad start for someone new to VBA.
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim wdDoc As Word.document
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Set WdApp = CreateObject("Word.Application")
Do Until FilterValue = 0
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
'moved outside of loop
' Set WdApp = CreateObject("Word.Application")
With WdApp
.Visible = True
.Activate
'create new document and assign to object variable
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\IBD Registry Quarterly Report Template2.dotx")
'now mostly finished with WdApp as from here wdDoc is used
End With
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
' .Selection.GoTo what:=-1, Name:="TableLocation"
' .Selection.Paste
wdDoc.Bookmarks("TableLocation").Range.Paste
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
' Sheets("Static").Select
' Sheets("Static").Activate
Organisation = WS.Range("D2").Value
' Sheets("Static").Select
' Range("D2").Copy
WS.Range("D2").Copy
' .Selection.GoTo what:=-1, Name:="Organisation"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("Organisation").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
' Sheets("Static").Select
' Range("F2").Copy
WS.Range("F2").Copy
' .Selection.GoTo what:=-1, Name:="MalePatients"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("MalePatients").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
Chart2.ChartArea.Copy
' .Selection.GoTo what:=-1, Name:="ChartLocation"
' .Selection.Paste
wdDoc.Bookmarks("ChartLocation").Range.Paste
If .Version <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & FileExt
If .Version <= 12 Then
' .ActiveDocument.SaveAs SaveName
wdDoc.SaveAs SaveName
Else
' .ActiveDocument.SaveAs2 SaveName
wdDoc.SaveAs2 SaveName
End If
SaveNamePDF = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & ".pdf"
wdDoc.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
wdDoc.Close
'moved outside of loop
'are you sure that these need to be inside the loop?
FilterValue = FilterValue - 1
Sheets("Static").Delete
Loop
WdApp.Quit
Set WdApp = Nothing
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub
Given a workbook like this one:
I need to add the logo from cell A2 - worksheet A, in the footer of worksheets B,C.
Here's the code I've found and modified a little bit but it is not working.
Sub Logo()
Dim printWorksheet As Worksheet
Dim logoShape As Shape
Dim tempImageFile As String
Set printWorksheet = ThisWorkbook.ActiveSheet
Set logoShape = ThisWorkbook.Sheets("A").Shapes("myLogo")
tempImageFile = Environ("temp") & Application.PathSeparator & "image.jpg"
Save_Object_As_Picture logoShape, tempImageFile
With printWorksheet.PageSetup
.RightHeaderPicture.FileName = tempImageFile
.RightHeader = "&G"
End With
I have found a solutions (http://www.vbforums.com/showthread.php?538529-Export-an-Image-from-Excel-Sheet-to-Hard-Drive), that I have adopted to this task.
The key is, that a chart object can be exported as a picture, so the original shape is copied into a chart.
The chart is created, used, and deleted.
The ShapeExportAsPicture has two arguments: the shape, that is to be exported as picture and the full path where to store it.
Sub Logo()
Dim printWorksheet As Worksheet
Dim logoShape As Shape
Dim tempImageFile As String
Set printWorksheet = ThisWorkbook.ActiveSheet
Set logoShape = ThisWorkbook.Sheets("A").Shapes("myLogo")
logoShape.Visible = True
tempImageFile = Environ("temp") & Application.PathSeparator & "image.jpg"
Call ShapeExportAsPicture(logoShape, tempImageFile)
With printWorksheet.PageSetup
.RightFooterPicture.Filename = tempImageFile
.RightFooter = "&G"
End With
logoShape.Visible = False
End Sub
Private Sub ShapeExportAsPicture(pShape As Shape, sPathImageLocation As String)
Dim sTempChart As String
Dim shTempSheet As Worksheet
Set shTempSheet = pShape.Parent
Charts.Add 'Add a temporary chart
ActiveChart.Location Where:=xlLocationAsObject, Name:=shTempSheet.Name
Selection.Border.LineStyle = 0
sTempChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With shTempSheet
'Change the dimensions of the chart to the size of the original shape
With .Shapes(sTempChart)
.Width = pShape.Width
.Height = pShape.Height
End With
pShape.Copy 'Copy the shape
With ActiveChart 'Paste the shape into the chart
.ChartArea.Select
.Paste
End With
'export the chart
.ChartObjects(1).Chart.Export Filename:=sPathImageLocation, FilterName:="jpg"
.Shapes(sTempChart).Delete 'Delete the chart.
End With
End Sub
I would like to combine sheets with the same name & format from multiple files into a single summary sheet. I used this code to do it but I found it won't copy any filtered data or link cells. I also tried a couple codes to remove the filter, and the copied data becomes uncontinuous. Could someone look into this and help me? Thanks!
Sub Multiple_to_One()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Dim lo As ListObject
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsm")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
With Workbooks(1).ActiveSheet
Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Wb.Close False
End With
End If
MyName = Dir
Loop
MsgBox "All done.", vbInformation, "bingo"
End Sub
This is a bit of a brute force method, but seems to work:
Sub Summarize()
Dim sourcePath As String
Dim sourceName As String
Dim sourceWorkbook as Workbook ' Workbook to be copied
Dim sourceSheet as Worksheet
Dim thisWorkbookName as String
Dim copyCell as Range
Dim sourceBase as Range ' Summary starts here
Application.ScreenUpdating = False
sourcePath = ActiveWorkbook.Path
thisWorkbookName = ActiveWorkbook.Name
sourceName = Dir(MyPath & "\" & "*.xlsm")
Set sourceBase = Workbooks(1).ActiveSheet.Range("A1") ' Set to what you want
Do While sourceName <> ""
If sourceName <> thisWorkbookName Then
Set sourceWorkbook = Workbooks.Open(sourcePath & "\" & sourceName)
Set sourceSheet = sourceWorkbook.Sheets(13)
For Each copyCell In sourceSheet.UsedRange
copyCell.Copy sourceBase.Offset(copyCell.Row - 1, copyCell.Column - 1)
Next
Set sourceBase = sourceBase.Offset(sourceSheet.UsedRange.Rows.Count)
Set copyCell = Nothing
Set sourceSheet = Nothing
sourceWorkbook.Close False
End If
sourceName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "All done.", vbInformation, "bingo"
End Sub
I'm just manually copying every cell in the used range into the target sheet. The base cell gets reset after each sheet, so it should just keep appending to the target sheet.
Caveat
I've only tested the inner code in my own sheet. I made adjustments on the fly to fit everything into your original logic. The entire function above should replace your original function. If you have errors, it's because I mistyped something. My apologies.
I set the autofiltermode to False. This worked in my case.
Wb.Sheets(13).AutoFilterMode = False
Here is the modified code.
Sub Multiple_to_One()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Dim lo As ListObject
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsm")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Wb.Sheets(13).AutoFilterMode = False
ThisWorkbook.Activate
With Workbooks(1).ActiveSheet
Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Wb.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "All done.", vbInformation, "bingo"
End Sub
I would like to make this code save the image name from a value in a cell. For example if "cat" was in the cell Y36 I would like it to be called cat.jpg.
The code below works when I don't have & FileNumber & in it or FileNumber = Range("Y36").
Sub ExportCellsAsPicture()
FileNumber = Range("Y36")
Const FName As String = "HD:Users:User:Desktop:" & FileNumber & ".jpg"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("QR Code").Range("Y50:AS70") 'Set your range here
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 10
.Height = PicTemp.Height + 10
End With
ChTemp.Export Filename:="HD:Users:User:Desktop:" & FileNumber & ".jpg", FilterName:="jpg"
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
UPDATE: WORKING CODE
Sub whatsup()
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Dim fileCon As String
fileCon = "JK"
Application.ScreenUpdating = False
Set pic_rng = Worksheets("QR Code").Range("Y50:AS70") 'Set your range here
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
'Here I want the .jpg to be called test_yyyy_mm_dd.jpg
ChTemp.Export Filename:="HD:Users:User1:Desktop:" & fileCon & ".jpg"
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Change the Const to a variable. By Definition, a Const(ant) can't change, but you are using it like a variable. Change it to these two lines:
Dim FName As String
FName = "HD:Users:User:Desktop:" & FileNumber & ".jpg"
You should also declare FileNumber before you set it.
Dim FileNumber As Long 'if this is a number. If not, string
FileNumber = Range("Y36")
And finally, it is always good to make everything Explicit and compile to be sure at least your syntax is correct. This will help reduce many simple but easy to miss errors. Place this at the very top of your module:
Option Explicit
Then compile and correct any syntax errors before debugging.
To debug, set a breakpoint on your first executable line (not a Dim statement) and step through line by line checking to see if it is working as you expect.
I've made a macro that suites my needs perfectly except for one thing. Currently it creates new workbooks for me with no format. I would like to change this so that it references a template and uses that formatting.
I've been messing with the "Set wbDest = Workbooks.Add(xlWBATWorksheet)" line, but can't seem to get anything to work!
Private Sub CommandButton1_Click()
Const sColumn As String = "M"
Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range
Set rngFilter = Range(sColumn & "1", Range(sColumn & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range(sColumn & "2", Range(sColumn & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End With
For Each cell In rngUniques
Set wbDest = Workbooks.Add(xlWBATWorksheet)
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngFilter.EntireRow.Copy
With wbDest.Sheets(1).Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
End With
Application.CutCopyMode = True
wbDest.Sheets(1).Name = cell.Value
Application.DisplayAlerts = False
wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & cell.Value & " " & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "mm-yy")
wbDest.Close False
Application.DisplayAlerts = True
Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
`
Workbooks.Add() accepts a single argument - Template. So create a template, save it as an .xltx file, then use that filepath to add your new workbook:
Dim wb As Workbook
Dim filepath As String
filepath = "C:\template.xltx" 'Or what-ever...
Set wb = Application.Workbooks.Add(filepath)
With wb
'...
End With
how about..
Dim wbTemplate As Workbook
Set wbTemplate = Workbooks.Open("C:\mytemplate.xlsx")
Where mytemplate.xlsx is your preformatted template. The reason I assigned it to a variable object is because it looks like you'll need to reference it in order to enter data onto the template. If you simply trying to open a workbook, the one-liner below is acceptable..
Workbooks.Open("C:\mytemplate.xlsx")