This Program is Supposed to Open A whole lot of Workbooks, the One at the top of the list (filename1, AKA Plan) is a place to upload many different cells of data, every other opened workbook is functionally the same. The file opening present no issues.
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim fd As FileDialog
Dim FileName1 As String
Dim Plan, Leg As Workbook
Dim FileChosen As Integer
Dim CUILT As String
Dim CuiltRange As Range
Set fd = Application.FileDialog(msoFileDialogOpen)
FileChosen = fd.Show
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
fd.Filters.Clear
fd.Filters.Add "Plan Excel", "*.xlsx"
fd.Filters.Add "Leg Excel, "*.xlsm"
fd2.FilterIndex = 1
If FileChosen <> -1 Then
MsgBox "The Operation has been stopped"
Else
FileName1 = fd2.SelectedItems(1)
Workbooks.Open (FileName1)
Set Plan = ActiveWorkbook
For i = 2 To fd2.SelectedItems.Count
Workbooks.Open fd2.SelectedItems(i)
Set Leg = ActiveWorkbook
CUILT = Leg.Sheets(1).Range("I19").Value
Plan.Worksheets(1).Activate
Now comes the part of the code that's giving me trouble, with the help of some other post I was able to navigate through the finicky nature of the find:Variable function, but right after I was able to sort that error, the "Found Range Variable = Range" now just doesn't want to cooperate. It gives me error 91, it's as if CuiltRow is not actually saving any value in the previous Set operation, even when I try to MsgBox after "Set" to figure it out, if just tells me its not defined, Every other out I've tried has ended in
error 438 "object doesn't support property or method".
Set CuiltRow = Plan.Sheets(1).Range("C16:C421").Find(CUILT, LookIn:=xlValues, LookAt:=xlWhole)
CuiltRow.Offset(0, 5).Range("A1").Value = Leg.Sheets(1).Range("D14").Value
The Set CuiltRow wont work without the Set, and I know the set is the one causing the 91? Honestly, im at a loss, Any help Would be Appreciated!
Next i
'Else
'End If
MsgBox "Operation has been completed"
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
End If
End Sub
I Just want to use the range CuiltRow returns as a reference waypoint to set many offsets, but with my poor syntax in "Range(offset) = Range" function VBA believes I'm trying to set a Value into a Range Object, how can I express it differently so its clear?
Related
I am trying to make a macro to open a word document and make track changes in accordance with column A and B.
I got this to work, but only if the document that is opened in the track changes mode "Simple Markup".
If it is in any other mode, and I have the following search sentences.
A1: al anden personer B1: alle andre mennesker
A2: anden personer B2: andre mennesker
And the text in the word document is "al anden personer".
The text will be "alle andre menneskerandre mennesker" in other world it will search in the track changes.
Therefore, I am trying to make the Word document always open in simple markup. I have tried using iteration of
ActiveWindow.View.RevisionsFilter.Markup = wdRevisionsMarkupSimple
but could not get it to work.
Hope you can help.
PS: I am fairly new to VBA so if you have any other improvement or hint the I'm all ears.
My code right now is:
Option Explicit
Const wdReplaceAll = 2
Sub FindReplace()
Dim wordApp As Object
Dim wordDoc As Object
Dim myStoryRange As Object
Dim cell As Range
Dim Find1 As String
Dim Replace1 As String
Const wdRevisionsMarkupSimple As Integer = 1
'Dim oRevision As Revision
If Not FileIsOpen("H:\Til excel replace test ark" & ".docx") Then
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Open("H:\Til excel replace test ark.docx")
wordDoc.trackrevisions = True
'ActiveWindow.View.RevisionsFilter.Markup = wdRevisionsMarkupSimple cannot get it to work
Else
On Error GoTo ExitSub
End If
With Worksheets("sheet1")
For Each cell In Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
Find1 = cell.Value
Replace1 = cell.Offset(0, 1).Value
For Each myStoryRange In wordDoc.StoryRanges
With myStoryRange.Find
.MatchCase = True
.matchwholeword = True
.Text = Find1
.Forward = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Replacement.Text = Replace1
.Execute Replace:=wdReplaceAll
End With
Next myStoryRange
Next cell
End With
Exit Sub
ExitSub:
MsgBox "Luk word document før du benytter denne macro"
End Sub
Public Function FileIsOpen(FullFilePath As String) As Boolean
Dim ff As Long
On Error Resume Next
ff = FreeFile()
Open FullFilePath For Input Lock Read As #ff
Close ff
FileIsOpen = (Err.Number <> 0)
On Error GoTo 0
End Function
Your issue is a result of your use of late binding.
When using late binding you cannot use the enums or constants from the Word object library, e.g. wdRevisionsMarkupSimple, as Excel doesn't know what those represent. You either have to declare those constants yourself or use their underlying values.
So to activate revisions with simple markup your code needs to be:
ActiveWindow.View.RevisionsFilter.Markup = 1 'wdRevisionsMarkupSimple
EDIT: I also missed something else obvious - Excel also has ActiveWindow in its object model. When writing code across applications you need to be absolutely scrupulous in specifying which application/object the line of code refers to. In this case it should be:
WordApp.ActiveWindow.View.RevisionsFilter.Markup = 1 'wdRevisionsMarkupSimple
You can avoid these errors 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 open the VBE and go to Tools | Options. In the Options dialog ensure that Require Variable Declaration is checked.
I want to call a vba function from vbscript which has a parameter, I Know how to call a parameterized sub but having issue with function
Here is what I have tried, I tried the code here Calling vba function(with parameters) from vbscript and show the result , but this also didn't work, it gave an error as expected end of statement
Set xlObj = CreateObject("Excel.Application")
Set objWorkbook = xlObj.Workbooks.Open("E:\Headers.xlsm")
xlObj.Application.Visible = False
xlObj.Workbooks.Add
Dim result
result = xlObj.Application.Run("Headers.xlsm!Headers",filename)
xlFile.Close True
xlObj.Quit
this my vba function
Function Headers(filename As String) As String
Application.ScreenUpdating = False
Dim myWb As Workbook
Dim i As Integer
Dim flag As Boolean
Set myWb = Workbooks.Open(filename:=filename)
Dim arr
arr = Array("col1","col2")
For i = 1 To 2
If Cells(1, i).Value = arr(i - 1) Then
Headers = "True"
Else
Headers = "False , Not Found Header " & arr(i - 1)
Exit Function
End If
Next
myWb.Close
End Function
In your VBScript xlObj is set to be an application Set xlObj = CreateObject("Excel.Application"). That means xlObj.Application should be xlObj only.
In your VBScript Filename is not declared nor set to a value therefore it is empty. You need to define value to it.
Set xlObj = CreateObject("Excel.Application")
Set objWorkbook = xlObj.Workbooks.Open("E:\Headers.xlsm")
xlObj.Visible = False
xlObj.Workbooks.Add
Dim Filename 'declare filename and set a value to it
Filename = "E:\YourPath\Yourfile.xlsx"
Dim Result
Result = xlObj.Run("Headers.xlsm!Headers", Filename)
xlFile.Close True
xlObj.Quit
In your function you use Exit Function. This will stop the code immediately at this point, which means your workbook myWb will not be closed! It stays open because myWb.Close is never reached. Change Exit Function to Exit For to just exit the loop and continue to close the workbook.
Cells(1, i).Value is neither specified which workbook it is in nor which worksheet. This is not very reliable never call Cells or Range without specifying workbook and worksheet (or Excel will guess which one you mean, and Excel can fail if you are not precise).
Therfore I recommend to use something like myWb.Worksheets(1).Cells(1, i).Value if you always mean the first worsheet in that workbook. Alternatively if it has a defined name using its name would be more reliable: myWb.Worksheets("SheetName").Cells(1, i).Value
If you turn off ScreenUpdating don't forget to turn it on in the end.
Error handling in case filename does not exist would be nice to not break the function.
You can slightly improve speed by assuming Headers = "True" as default and just turn it False in case you find any non matching header. This way the variable is only set once to True instead of multiple times for every correct header.
Public Function Headers(ByVal Filename As String) As String
Application.ScreenUpdating = False
Dim flag As Boolean 'flag is never used! you can remove it
On Error Resume Next 'error handling here would be nice to not break if filename does not exist.
Dim myWb As Workbook
Set myWb = Workbooks.Open(Filename:=Filename)
On Error Goro 0 'always reactivate error reporting after Resume Next!!!
If Not myWb Is Nothing Then
Dim Arr() As Variant
Arr = Array("col1", "col2")
Headers = "True" 'assume True as default and just change it to False if a non matching header was found (faster because variable is only set true once instead for every column).
Dim i As Long 'better use Long since there is no benefit in using Integer
For i = 1 To UBound(arr) + 1 'use `ubound to find the upper index of the array, so if you add col3 you don't need to change the loop boundings
If Not myWb.Worksheets(1).Cells(1, i).Value = Arr(i - 1) Then 'define workbook and worksheet for cells
Headers = "False , Not Found Header " & Arr(i - 1)
Exit For '<-- just exit loop but still close the workbook
End If
Next i
Else
Headers = "File '" & Filename & "' not found!"
End If
Application.ScreenUpdating = True
myWb.Close
End Function
I have a VBA macro that cycles through a list of 1500 PDF Files Ranging from 60 to 500 pages. The code checks each file from the list to see if it contains a certain keyword obtained from a user. The code seems to bug out sometimes if the file is too big, so I limited each pdf that will be searched to 12 MB.
Now The problem I am having is that randomly the macro will just stall on a random file and not do anything regardless of file size. It will just stay on that file unless I go and move the mouse.
So I was wondering what the best way to tackle this would be? I was thinking of adding an event of moving the mouse before and after the .FindText method, but I think the best way would be to limit the time each file is open to 30 seconds. I am not sure how to incorporate it within the loop though, Thanks.
Also if you have any suggestions on other improvements I would aprreciate it thank you.
Sub PDFSearch()
Dim FileList As Worksheet, Results As Worksheet
Dim LastRow As Long, FileSize As Long
Dim KeyWord As String
Dim TooLarge As Boolean
Dim PDFApp As Object, PDFDoc As Object
Application.DisplayAlerts = False
Set FileList = ThisWorkbook.Worksheets("Files")
Set Results = ThisWorkbook.Worksheets("Results")
LastRow = FileList.Cells(Rows.Count, 1).End(xlUp).Row
KeyWord = InputBox("What Term Would You Like To Search For?")
Results.Rows(3 & ":" & .Rows.Count).ClearContents
For x = 3 To LastRow
TooLarge = False
FileSize = FileLen(FileList.Cells(x, 1).Value) / 1000
If FileSize > 12000 Then TooLarge = True
If TooLarge = False Then
Set PDFApp = CreateObject("AcroExch.App")
If Err.Number <> 0 Then
MsgBox "Could not create the Adobe Application object!", vbCritical, "Object Error"
Set PDFApp = Nothing
Exit Sub
End If
On Error Resume Next
App.CloseAllDocs 'Precautionary - Sometimes It Doesn't Close The File
On Error GoTo 0
Set PDFDoc = CreateObject("AcroExch.AVDoc")
If Err.Number <> 0 Then
MsgBox "Could not create the AVDoc object!", vbCritical, "Object Error"
Set PDFDoc = Nothing
Set PDFApp = Nothing
Exit Sub
End If
If PDFDoc.Open(FileList.Cells(x, 1).Value, "") = True Then
PDFDoc.BringToFront
If PDFDoc.FindText(KeyWord, False, False, True) = True Then
Results.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = FileList.Cells(x, 1).Value
End If
End If
PDFApp.Exit
End If
On Error Resume Next
PDFDoc.BringToFront 'Precautionary - Sometimes Command Doesn't Close The File
PDFApp.Exit
On Error GoTo 0
Set PDFDoc = Nothing
Set PDFApp = Nothing
FileSize = 0
Next x
Application.DisplayAlerts = True
End Sub
I am getting inconsistent results when I try to refer to an active workbook. About half the time I get the "Method of 'Sheets' of Object '_Global' not failed" error and other times the code works fine. I don't see a pattern.
The VBA code is part of a Word document that allows the user to open a template Excel file and select/copy text from the Word doc into rows on the Excel file.
In a previous sub I successfully open an Excel template file (I call it a RTM template). In the code below I want to activate the "RTM" worksheet, select the first cell where the template could already have data in it from a previous execution and if there is, then count how many rows of data exist. In this way the new data will be posted in the first row which does not have any data. I am using named ranges in my Workbook to refer to the starting cell ("First_Cell_For_Data").
When I run my code sometimes it runs without error and other times it stops on the "Sheets("RTM").Activate" and gives me the "Method...." error. The same result occurs when I change the variable definition of wb_open to Object. I have also tried using "wb_open.Sheets("RTM").Activate" with the same results.
As suggested in the comments below I added "If wb_open is nothing ...." to debug the issue. I also added the sub List_Open_Workbooks which enumerates the open workbooks (of which there is only 1) and activates the one that matches the name of the one with the correct filename. This is successful. But upon returning to Check_Excel_RTM_Template I still get the Method error on the "Sheets("RTM").Activate" line.
Second Update: after more time diagnosing the problem (which still occurs intermittently) I have added some code that may help getting to the root of the problem. In the "List_Open_Workbooks" sub I test for xlApp.Workbooks.Count = 0. So all references to an open Excel workbook will fail. At this point my template workbook is open in Windows. Am I drawing the correct conclusion?
Third Update: I tried Set wb_open = GetObject(str_filename) where str_filename contains the name of the Excel template file I just opened.
I get the following error message.
Also, I noticed that if I start with a fresh launch of Word and Excel it seems to run just fine.
Sub Check_Excel_RTM_Template(b_Excel_File_Has_Data As Boolean, i_rows_of_data As Integer)
Dim i_starting_row_for_data As Integer
Dim wb_open As Object
Set wb_open = ActiveWorkbook
i_rows_of_data = 0
If wb_open Is Nothing Then
MsgBox "RTM Workbook not open in Check_Excel_RTM_Template"
Call List_Open_Workbooks(b_Excel_File_Has_Data, i_rows_of_data)
Else
' On Error GoTo Err1:
' Sheets("RTM").Activate
' range("First_Cell_For_Data").Select
Workbooks(wb_open.Name).Worksheets("RTM").range("First_Cell_For_Data").Select
If Trim(ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(ActiveCell.Value) = ""
ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
End If
Exit Sub
Err1:
MsgBox getName(str_Excel_Filename) & " is not a RTM template file."
b_abort = True
End Sub
Sub to enumerate all open workbooks
Sub List_Open_Workbooks(b_Excel_File_Has_Data As Boolean, i_rows_of_data As Integer)
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
Dim str_filename As String
Dim xlWB As Excel.Workbook
If xlApp.Workbooks.Count = 0 Then
MsgBox "Error: Windows thinks there are no workbooks open in List_Open_Workbooks"
b_abort = True
Exit Sub
End If
For Each xlWB In xlApp.Workbooks
Debug.Print xlWB.Name
str_filename = getName(str_Excel_Filename)
If Trim(xlWB.Name) = Trim(str_filename) Then
xlWB.Activate
If xlWB Is Nothing Then
MsgBox "Workbook still not active in List_Open_Workbooks"
b_abort = True
Exit Sub
Else
' Sheets("RTM").Activate
Workbooks(xlWB.Name).Worksheets("RTM").range("First_Cell_For_Data").Select
range("First_Cell_For_Data").Select
If Trim(ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(ActiveCell.Value) = ""
ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
End If
End If
Next xlWB
Set xlApp = Nothing
Set xlWB = Nothing
End Sub
Function to extract filename from path/filename
Function getName(pf)
getName = Split(Mid(pf, InStrRev(pf, "\") + 1), ".")(0) & ".xlsx"
End Function
I am hoping I found the source of my problem and solved it.
I believe that referring to an open workbook in sub using Dim wb_open As Object & Set wb_open = ActiveWorkbook in the Check_Excel_RTM_Template sub is causing my inconsistent problems....perhaps this is an anomoly (bug) in the VBA implementation in Word.
In the revised code I posted below I am passing the o_Excel object from the calling routine and using oExcel.Activesheet.xxx to reference ranges and values.
Now I next problem is that I am having errors on the form control button code which also uses the Dim wb_open As Object & Set wb_open = ActiveWorkbook approach to referring to the open workbook. But I'll post that as a new question.
Thanks to all who commented and provided suggestions.
Sub Check_Excel_RTM_Template(oExcel As Object)
Dim i_starting_row_for_data As Integer
Dim str_filename As String
i_rows_of_data = 0
On Error GoTo Err1:
oExcel.ActiveSheet.range("First_Cell_For_Data").Select
If Trim(oExcel.ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(oExcel.ActiveCell.Value) = ""
oExcel.ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
Exit Sub
Err1:
Documents(str_doc_index).Activate
MsgBox getName(str_Excel_Filename) & " is not a RTM template file."
b_abort = True
End Sub
SOLVED! See the code below for the solution!
I have an Excel file containing multiple shape objects next to a series of text. I wrote a script to identify the location of each shape, identify how many cells to the right and down the text extends to, sets that as a range and then imports that into a chart object so I can save it as a .jpg.
The trouble is that between the creation of the chart and the pasting of the string there exists a Race Condition. If I step through the script it works fine, but as soon as I run it I get nothing but blank images.
I've tried Application.ScreenUpdating = True; Application.PrintCommunication = True; and DoEvents
I've also tried Application.Wait, but even having it wait ten seconds doesn't do the trick, when stepping through the code the chart is loaded in less than 2 seconds.
Recently I tried the kernel32 sleep method as well, and that doesn't seem to work either. Again, the amount of time I let the system sleep far exceeded my stepping. I also added all of the above methods between each line within the With statement (obviously not as a solution, but as a test) and that didn't work either..
At this point I'm completely at a loss.
If I place a stop at .Chart.Paste and then run the script (F5), and just keep hitting Run then the script works wonderfully. I just don't want users to have to sit there and hit run 600 times.
There are obvious redundancies written in between the creation of the chart and pasting of the text. This is all in the attempt at getting the code to work properly when run, and once a solution is found most of that code will be removed.
Option Explicit
Public Function ChartCheck() As String
ReCheckChart:
DoEvents
If ActiveWorkbook.ActiveSheet.ChartObjects.Count > 0 Then
GoTo ContinuePaste:
Else
GoTo ReCheckChart:
ContinuePaste:
End If
End Function
Public Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to Save the Images In"
.AllowMultiSelect = False
If .Show -1 Then GoTo NextCode:
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Private Sub DNImageExtraction_Click()
Dim fileName As String
Dim targetWorkbook As Excel.Workbook
Dim targetWorksheet As Excel.Worksheet
Dim saveLocation As Variant
Dim saveName As String
Dim targetShape As Shape
Dim workingRange As Excel.Range
Dim bottomRow As Long
Dim workingRangeWidth As Double
Dim workingRangeHeight As Double
Dim tempChart As ChartObject
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DNImageExtraction.AutoSize = False 'This is necessary to prevent the system I use from altering the font on the button
DNImageExtraction.AutoSize = True
DNImageExtraction.Height = 38.4
DNImageExtraction.Left = 19.2
DNImageExtraction.Width = 133.8
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")
Set targetWorkbook = Workbooks.Open(fileName)
Set targetWorksheet = targetWorkbook.ActiveSheet
saveLocation = GetFolder
For Each targetShape In targetWorksheet.Shapes
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)
saveName = workingRange.Text
If workingRange.Offset(0, 1).Value "" Then
If workingRange.Offset(1, 1).Value = "" Then
Set workingRange = Nothing
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
Else
bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
End If
workingRangeWidth = workingRange.Width
workingRangeHeight = workingRange.Height
End If
workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)
Application.ScreenUpdating = True
Application.PrintCommunication = True
DoEvents
Call ChartCheck
tempChart.Chart.Paste
Application.ScreenUpdating = False
tempChart.Chart.Export fileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
tempChart.Delete
Set tempChart = Nothing
Next
Application.Workbooks(targetWorkbook.Name).Close savechanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Any assistance in either a solution to the Race Condition, or re organizing the script to avoid the Race Condition altogether would be greatly appreciated.
(Code above was updated per suggestions made by Macro Man, and then re-modified once again to add in all previous suggestions on how to fix Race Condition issues after the changes were not effective.)
Consider using Application.OnTime which is good feature. It allows the scheduling of some code to be run at a certain time, most often one adds a few seconds to the current time.
Excel VBA is single-threaded and so there is no real synchronization but there is a message pump to keep order. The great thing about Application.OnTime is that it will not run despite being scheduled until the current graph of code has completed.
Because Application.OnTime uses the message pump as that is a FIFO structure it is possible to interleave the execution of code.
I think this might help here.
You can schedule a "hasItFinished" procedure which checks the existence of the shape/chart objects and if not re-schedules itself.
P.S. Can be a little tricky to debug, refactor as much code as possible outside of the procedure that you will schedule and unit test them separately. Please don't expect the lovely Edit,Debug and Continue flow that you normally get with VBA if you go down this path.
Try getting rid of the error handlers and labels, and working with objects directly instead of searching through workbook/worksheet collections. Also using meaningful variable names and proper indentation will help follow the code easily should you have any issues.
If your code works when stepping through, that usually suggests there is some issue with the use of ActiveWorkbook when workbooks are being opened/closed. Working with workbooks as objects allows us to overcome that problem because no matter if the workbook is active or not, we are always using the same instance of that workbook.
Private Sub DNImageExtraction_Click()
Dim fileName As String
Dim targetWorkbook As Excel.Workbook
Dim targetWorksheet As Excel.Worksheet
Dim saveLocation As Variant
Dim saveName As String
Dim targetShape As Shape
Dim workingRange As Excel.Range
Dim bottomRow As Long
Dim workingRangeWidth As Double
Dim workingRangeHeight As Double
Dim tempChart As ChartObject
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")
Set targetWorkbook = Workbooks.Open(fileName)
Set targetWorksheet = targetWorkbook.ActiveSheet
saveLocation = GetFolder
For Each targetShape In targetWorksheet.Shapes
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)
saveName = workingRange.Text
If workingRange.Offset(0, 1).value <> "" Then
If workingRange.Offset(1, 1).value = "" Then
Set workingRange = Nothing
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
Else
bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
End If
workingRangeWidth = workingRange.Width
workingRangeHeight = workingRange.Height
End If
workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)
With tempChart
.Chart.Paste
.Chart.Export FileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
.Delete
End With
Set tmpChart = Nothing
DoEvents
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub