I have been trying for a while now to edit different code pieces found online to save only the used range of my active workbook as a jpg to my SharePoint online directory. I managed to make a VBA Code work that saves the range as a jpg in a local path but when I change this path to my SharePoint online link it only opens my file explorer and asks me to SaveAs.
I am very new to VBA so I basically have no experience and would therefore be very thankful for any help. Below the VBA Code that does not work right now.
I am pretty sure that the issue lies within the ExportName= ... and ChO.Chart.Export since I took this part from a code that SavesAs to a local path. But like mentioned before I am very new to VBA and therefore have no idea how to recode this to my use case.
Sub SaveAsJPG()
Dim ChO As ChartObject, ExportName As String
Dim CopyRange As Range
Dim Pic As Picture
Dim i As Long
Dim SharePointAdress As String
'My SharePoint Online Adress
SharePointAdress = "https://xxxxxx.sharepoint.com/sites/xxxxx/Shared Documents" & "/"
With ActiveSheet
Set CopyRange = .UsedRange
If Not CopyRange Is Nothing Then
Application.ScreenUpdating = False
ExportName = Application.GetSaveAsFilename(InitialFileName:=SharePointAdress & .Range("A1") & "_" & .Range("J1"), FileFilter:="JPEG Files (*.jpg), *.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
End Sub
Range A1 & J1 have the name of the Table & the current calender week inside (so the filename is variable). I do not have the option to connect the SharePoint Link to the network folders.
Thank you for any help for a newbie! :)
Related
I have ran into an automation issue that I cannot seem to figure out.
Currently, I have a worksheet,("Project") that contains data in columns "A"(Project Name) & "B"(Project File Location).
Column "B" contains the string location of each MS Project file.
My VBA macro loops through column "B" and opens each MS Project file and copies a task with the .SelectTaskField method and then copies it back into column "E" of the worksheet.
The first 2 projects loop through without any issues, however, on the 3rd project, I receive the Run-time error '1004': An unexpected error occurred with the method.
I co-worker and I have poured through the code and the MS Project Files to see if there are any differences in the data and we cannot find any differences.
Below is a copy of the code that I have been using.
Just wanted to see if anyone else has had similar issues. I have found that MS Project does not like to be manipulated like Excel or Word.
Any help would be greatly appreciated.
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
'Turns off updates and alerts
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Select Daily Field Reports and clear worksheet
ws.Range("E2:E" & lrow).ClearContents
'Opens MS Project
Set objproject = CreateObject("MSProject.Project")
'This keeps MS Project invisible. If you want to see it, change to "True"
objproject.Application.Visible = True
Dim oproject As Range
'This cycles through the range and gathers the data for each project
For Each oproject In Range("B2:B" & lrow)
Set objproject = CreateObject("MSProject.Project")
oproject.Select
objproject.Application.FileOpen Selection
objproject.Application.Visible = True
objproject.Application.SelectTaskField Row:=1, Column:="Percent Complete", RowRelative:=False 'The column name must match. This is the only issue that I have uncovered.
objproject.Application.EditCopy
ws.Select
Dim lastrow As Long
lastrow = ws.Cells(Rows.Count, "E").End(xlUp).Row + 1
Dim Rng As Range
Set Rng = ws.Range("E" & lastrow)
'Rng.PasteSpecial xlPasteFormats
Rng.PasteSpecial xlPasteValues
objproject.Application.Quit
Next oproject
'Turns updates and alerts back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Closes MS Project
objproject.Application.Quit
End Sub
Using the SelectTaskField method presumes the file was saved in a task view and that the column you want is in the table of the view. Better to get the values you need directly from the Task object.
It appears you are looking for the % Complete value from the first task. In that case use this:
objproject.ActiveProject.Tasks(1).PercentComplete
Here's how it could work in your code. I took the liberty of simplifying it a bit:
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ws.Range("E2:E" & lrow).ClearContents
Dim objproject As MSProject.Application
Set objproject = CreateObject("MSProject.Application")
objproject.Application.Visible = True
Dim oproject As Range
For Each oproject In Range("B2:B" & lrow)
objproject.FileOpen Name:=oproject.Value, ReadOnly:=True
oproject.Offset(, 3) = objproject.ActiveProject.Tasks(1).PercentComplete
objproject.FileCloseEx
Next oproject
Application.ScreenUpdating = True
Application.DisplayAlerts = True
objproject.Quit
End Sub
Note that it is more straight-forward to get a reference to the application object rather than a child of that object: CreateObject("MSProject.Application") is preferable to CreateObject("MSProject.Project").
this is the code that i am currently using right now, but its not enough to meet my objectives and i am stuck on how to continue....
So this code will copy the specified data from many other excel workbook in the form of xlsx into a main excel workbook and before that it will scan through the folder which contains all the different data files and the main file(all files supposed to be transfered here in a table form) e.g. Test3.xlsx,Test4.xlsx,Test.xlxs and Main.xlsm in the folder of ScanFiles. so everytime a new files comes into the folder, it will automatically update the main workbook by opening the data workbooks then copy the required data and paste it on the main workbook upon clicking a button.
Sub ScanFiles()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "c:\Scanfiles\"
myFile = Dir(path & "*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("sheet1").Range("A18,B18,C18,D18,A19,B19,C19,D19")
Windows("master-wbk.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Objectives: 1st:orignal type of file is in "file" not xlsx, so hope to find a way to open the file in xlsx format automatically before start of copying data.
2nd: requires 3 types of specified data e.g. name,surname(both of them are in fixed position always in A18 to D18 and A19 to D19 , 3rd one is to find the date, however the date is almost always in different positions in the data sheet, so i hope to add on a part to the code that makes it search for something like "ended 20190808" it will always start with ended but will always be in diff rows or even columns. i also need to arrange the data according to the date from newest(top) to oldest(bottom) and state the month of the date in words instead of numbers e.g. june
Deeply Appreciate any form of help but if possible the small section of code that can add on to my coding will make it a lot easier because im tasked to do this in a very limited amount of time
Thank you!!!
Here's some code that does similar things to what you describe. The animated .gif shows it working by stepping through the code. First the 2 data (.xlsx) files are shown so you have an idea of their content. Each is located in the same folder as the main workbook and has data in column A. Then as we step through the code each file is opened, its data manipulated (row 3 is deleted) and transferred into adjacent columns of the main workbook. The code is not limited to .xlsx files and will work with text files as well, as long as ext is defined.
Hopefully, once you understand how this works you can modify it to apply it to your case.
Option Explicit
Sub CombineFiles()
Dim theDir As String, numFiles As Integer
Dim sh As Worksheet, wk As Workbook, newSheet As Worksheet
Dim newColumn As Range, r As Range, s As String
Const ext = ".xlsx"
Err.Clear
theDir = ThisWorkbook.Path
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "Combined"
Set newColumn = newSheet.Range("A1")
'Loop through all files in directory
s = Dir(theDir & "\*" & ext)
While s <> ""
numFiles = numFiles + 1
On Error Resume Next
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = ActiveSheet
sh.Rows(3).Delete Shift:=xlUp
Set r = Range("A1")
Range(r, r.End(xlDown)).Copy
newSheet.Activate
newColumn.Offset(0, numFiles) = wk.Name
newColumn.Offset(1, numFiles).Select
newSheet.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
Wend
MsgBox (numFiles & " files were processed.")
End Sub
For copy/paste of pictures see examples on this or this page. To find the last cell containing data in a column see this page; note that one example involves using the .find command. More generally, to learn how to use .find in vba, use the macro recorder and then adjust the resulting code.
I've been using a function from another StackOverflow question (I'm SO sorry I can't find the original answer!) to help go through a number of cells in Column L that contains a formula that spits our a hyperlinked filepath. It is meant to open each one (workbook), update the values, then save and close the workbook before opening the next one. See below.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
' Update the individual credit models
With ThisWorkbook.Sheets("List")
lr = .Cells(.Rows.Count, "L").End(xlUp).Row
FileNames = .Range("L2:L" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
'do stuff here
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
MsgBox "The Following Files Could Not Be Opened" & _
Chr(10) & msg, 48, "Error"
End If
End Sub
The problem now is I am using this to work on a Network drive, and as a result it cause pathing issues with the Connections/Edit Links part. Each of the files are stored on S:\... which as a result of using the Hyperlink formula, won't be able to find the source data. See below the example image of a file that as been opened through a hyperlink cell from my original workbook. When I go to update the Edit Links section of it, it shows these errors.
If I open that lettered drive in Windows Explorer and find the file, it works with no problems. Open, Update Values > Save > Close, it says unknown...
(but if I click Update values here they update correctly.)
If opened using a Hyperlink formula in a cell (Also directing to S:\..) it says it contains links that cannot be updated. I choose to edit links and they're all "Error: Source not found". The location on them also starts off with \\\corp\... and not S:\.
Anyway to fix this? Apologies for the long winded question.
I'm adding this as an answer as it contains code and is a bit long for a comment.
I'm not sure if it's what you're after though.
The code will take the mapped drive and return the network drive, or visa-versa for Excel files. DriveMap is the variable containing the final string - you may want to adapt into a function.
Sub UpdatePath()
Dim oFSO As Object
Dim oDrv As Object
Dim FileName As String
Dim DriveMap As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileName = Range("A1")
If InStr(oFSO.GetExtensionName(FileName), "xls") > 0 Then
For Each oDrv In oFSO.drives
If oDrv.sharename <> "" Then
'Changes \\corp\.... to S:\
If InStr(FileName, oDrv.sharename) = 1 Then
DriveMap = Replace(FileName, oDrv.sharename, oDrv.Path)
End If
'Changes S:\ to \\corp\....
' If InStr(FileName, oDrv.Path) = 1 Then
' DriveMap = Replace(FileName, oDrv.Path, oDrv.sharename)
' End If
End If
Next oDrv
End If
End Sub
I found a code on the Internet and I've adapted to my own use to automate copy-paste. Works great except that when I paste the Excel chart to my word report, the colors get changed to destination theme. I need to keep source formatting and as the report is final, I can't change the color scheme either.
For some reason Selection.PasteSpecial (wdChart) does not work, it's used as a simple paste. I've got hundreds of reports to paste two dozens of graphs to, please don't say I will have to do it manually! Help please!
'You must set a reference to Microsoft Word Object Library from Tools | References
Option Explicit
Sub ExportToWord()
Dim appWrd As Object
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim x As Long
Dim LastRow As Long
Dim SheetChart As String
Dim SheetRange As String
Dim BookMarkChart As String
Dim BookMarkRange As String
Dim Prompt As String
Dim Title As String
'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Assign the Word file path and name to variables
FilePath = ThisWorkbook.path
FileName = "Trust03.docx"
'Determine the last row of data for our loop
LastRow = Sheets("Summary").Range("A65536").End(xlUp).Row
'Create an instance of Word for us to use
Set appWrd = CreateObject("Word.Application")
'Open our specified Word file, On Error is used in case the file is not there
On Error Resume Next
Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
On Error GoTo 0
'If the file is not found, we need to end the sub and let the user know
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
appWrd.Quit
Set appWrd = Nothing
Exit Sub
End If
'Copy/Paste Loop starts here
For x = 2 To LastRow
'Use the Status Bar to let the user know what the current progress is
Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & " (" & _
Format((x - 1) / (LastRow - 1), "Percent") & ")"
Application.StatusBar = Prompt
'Assign the worksheet names and bookmark names to a variable
'Use With to group these lines together
With ThisWorkbook.Sheets("Summary")
SheetChart = .Range("A" & x).Text
BookMarkChart = .Range("C" & x).Text
End With
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
'Paste into Word
appWrd.Selection.PasteSpecial (wdChart)
Next
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
'Let the user know the procedure is now complete
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title
'Make our Word session visible
appWrd.Visible = True
'Clean up
Set appWrd = Nothing
Set objDoc = Nothing
End Sub
Rather than using the Selection.PasteSpecial method I use Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
Change your paste line from
appWrd.Selection.PasteSpecial (wdChart)
to
appWrd.CommandBars.ExecuteMso ("PasteSourceFormatting")
appWrd.CommandBars.ReleaseFocus
Unfortunately MSDN doesn't have much in the way of documentation on this.... Hope it works for you without much trouble
EDIT
After some digging I figured out the the idMso parameter for this method corresponds to the ribbon controls idMso. A complete list of these can be found for each office application by going to File -> Options -> Customize Ribbon and then for each command hover over it in the list and the ToolTip will have a Description followed by a term enclosed in parentheses. This term in the parentheses is the idMso string for that command.
2nd EDIT
So here is how I do it from Excel to PowerPoint:
'Copy the object
Wkst.ChartObjects("ChartName").Select
Wkst.ChartObjects("ChartName").Copy
'Select Slide
Set mySlide = myPresentation.Slides("SlideName")
mySlide.Select
'stall to make sure the slide is selected
For k = 1 To 1000
DoEvents
Next k
'paste on selected slide
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPApp.CommandBars.ReleaseFocus
'sit and wait for changes to be made
For k = 1 To 5000
DoEvents
Next k
The wait loops with DoEvents (MSDN) are because this is within a loop pasting a dozen or so charts and then formatting them. I got errors in the next part of the loop (resizing the chart). But here I had to select the silde and wait for a moment before attempting the paste to make sure it was on the right slide. Without this it pasted on slide 1.
Nothing here sticks out to me as something you're ommitting but maybe it will help you see why it is not working.
I wonder whether someone can help me please.
I wanting to use this solution in a script I'm trying to put together, but I'm a little unsure about how to make a change which needs to be made.
You'll see in the solution that the file type which is opened is a Excel and indeed it's saved as such. But I the files I'd like to open and save are a mixture of .docx and .dat (Used by Dragon software) files.
Could someone possible tell me please is there a way by which I can amend the code so it opens and saves the files in file types other than Excel workbooks.
The reason behind this question because I'm currently using a script which creates a list of files in a Excel spreadsheet from a given folder. For each file that is retrieved there is a hyperlink, which I'd like to add fucntionality to which enables the user to copy the file and save it to a location of their choice.
To help this is the code which I use to create the list of files.
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
Dim LastRow As Long
Dim fName As String
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 12
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Formula = FileItem.Path
Cells(iRow, 6).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
For Each Cell In Range("C13:F" & LastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
Else
Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
End If
Next Cell
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Many thanks and kind regards
Chris
Miguel provided a fantastic solution which on initial testing appeared to work 100%. But as you will see from the comments at the end of the post there were some issues when the user cancelled the operation, so I made another post at this link where the problems were ironed out. Many thanks and kind regards. Chris
The code below shows how to retrieve the extension of a file, define an array with “allowed” extensions, and match the extension of the file to the array.
This is the outline for file manipulation, you'll just need to tailor it to you needs
Dim MinExtensionX
Dim Arr() As Variant
Dim lngLoc As Variant
'Retrieve extension of file
MinExtensionX = Mid(MyFile.Name, InStrRev(MyFile.Name, ".") + 1)
Arr = Array("xls", "xlsx", "docx", "dat") 'define which extensions you want to allow
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(MinExtensionX, Arr(), 0)
If Not IsEmpty(lngLoc) Then '
'check which kind of extension you are working with and create proper obj manipulation
If MinExtensionX = "docx" then
Set wApp = CreateObject("Word.Application")
wApp.DisplayAlerts = False
Set wDoc = wApp.Documents.Open (Filename:="C:\Documents\SomeWordTemplate.docx", ReadOnly:=True)
'DO STUFF if it's an authorized file. Then Save file.
With wDoc
.ActiveDocument.SaveAs Filename:="C:\Documents\NewWordDocumentFromTemplate.docx"
End With
wApp.DisplayAlerts = True
End if
End If
For files .Dat its a bit more complex, specially if you need to open/process data from the file, but this might help you out.
Edit:
2: Comments added
Hi IRHM,
I think you want something like this:
'Worksheet_FollowHyperlink' is an on click event that occurs every time you click on an Hyperlink within a Worksheet, You can find more here
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'disable events so the user doesn't see the codes selection
Application.EnableEvents = False
Dim FSO
Dim sFile As String
Dim sDFolder As String
Dim thiswb As Workbook ', wb As Workbook
'Define workbooks so we don't lose scope while selecting sFile(thisworkbook = workbook were the code is located).
Set thiswb = thisworkbook
'Set wb = ActiveWorkbook ' This line was commented out because we no longer need to cope with 2 excel workbooks open at the same time.
'Target.Range.Value is the selection of the Hyperlink Path. Due to the address of the Hyperlink being "" we just assign the value to a
'temporary variable which is not used so the Click on event is still triggers
temp = Target.Range.Value
'Activate the wb, and attribute the File.Path located 1 column left of the Hyperlink/ActiveCell
thiswb.Activate
sFile = Cells(ActiveCell.Row, ActiveCell.Column - 1).Value
'Declare a variable as a FileDialog Object
Dim fldr As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
'Allow only single selection on Folders
fldr.AllowMultiSelect = False
'Show Folder picker dialog box to user and wait for user action
fldr.Show
'add the end slash of the path selected in the dialog box for the copy operation
sDFolder = fldr.SelectedItems(1) & "\"
'FSO System object to copy the file
Set FSO = CreateObject("Scripting.FileSystemObject")
' Copy File from (source = sFile), destination , (Overwrite True = replace file with the same name)
FSO.CopyFile (sFile), sDFolder, True
' check if there's multiple excel workbooks open and close workbook that is not needed
' section commented out because the Hyperlinks no longer Open the selected file
' If Not thiswb.Name = wb.Name Then
' wb.Close
' End If
Application.EnableEvents = True
End Sub
The above code Triggers when you click the Hyperlink and it promps a folder selection window.
You just need to paste the code into the Worksheet code. And you should be good to go.