I've searched all google and I've tried some suggestions from stack overflow to achieve results but they seem to not work towards my specific goal. Wondering if anyone here can help me.
I work in a call center where I receive emails with agents productivity data on an hourly basis and it's beginning to be a lot of manual work. How can I get a macro to copy the email body and paste it to an excel sheet automatically? or I can run it daily.
This is an example of how the data looks
Hourly Productivity
The specific data I need to copy:
Agent Login | Agent Name | Average Talk Time | Total Talk Time | Calls Answered | Total ACW
I would also love to be able to include the date and hours of the productivity if possible? on the picture you will be able to see the time for it. (8:00 AM - 9:00 AM)
I would really appreciate any help in this.
Thanks in advance.
I think this should pretty much do what you want.
Sub Extract()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
xlobj.Worksheets("Sheet1").Name = "Statusmail"
'Set the header
xlobj.Range("a" & 1).Value = "Absender"
xlobj.Range("a" & 1).Font.Bold = "True"
xlobj.Range("b" & 1).Value = "Date"
xlobj.Range("b" & 1).Font.Bold = "True"
xlobj.Range("c" & 1).Value = "Task"
xlobj.Range("c" & 1).Font.Bold = True
xlobj.Range("d" & 1).Value = "Planed-date"
xlobj.Range("d" & 1).Font.Bold = True
xlobj.Range("e" & 1).Value = "deadline"
xlobj.Range("e" & 1).Font.Bold = True
xlobj.Range("f" & 1).Value = "finished"
xlobj.Range("f" & 1).Font.Bold = True
xlobj.Range("g" & 1).Value = "time effort"
xlobj.Range("g" & 1).Font.Bold = True
xlobj.Range("h" & 1).Value = "description"
xlobj.Range("h" & 1).Font.Bold = True
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
xlobj.Range("a" & i + 1).Value = myitem.To
xlobj.Range("b" & i + 1).Value = myitem.ReceivedTime
xlobj.Range("c" & i + 1).Value = msgtext
Next
End Sub
here is some code to get you started, it processes all selected messages, so select just one message of interest
it prints the message body type and body text into the "immediate window"
Public Sub exploreEmailMessage()
Dim currentItem As Object ' drag "currentItem" onto "Watches" window, or use: right-click ... Add Watch
For Each currentItem In Application.ActiveExplorer.Selection ' check Watches window after this line is executed
Stop
If currentItem.Class = olMail Then
Debug.Print "************************************"
Debug.Print currentItem.ReceivedTime
Debug.Print "************************************"
Debug.Print Array("Unspecified", "Plain", "HTML", "RichText")(currentItem.BodyFormat)
Debug.Print "************************************"
Debug.Print currentItem.Body
Debug.Print "************************************"
Debug.Print currentItem.HTMLBody
Debug.Print "************************************" ' copy text in "immediate window" and paste into text editor for analysis
End If
Next
End Sub
Related
So there are several SO questions and Google results that come up under "On Error GoTo executes once" and in just about every case the recommended solution is to add Err.Clear or some forum of Resume to clear the error out. VBA errors can only be handled one at a time, so they need to be cleared.
Having implemented these, as you might have guessed, I am running into this issue where the On Error GoTo is only executing once and I can't figure out why.
Below is my loop. I did leave some code off the top because there is quite a bit of it and it isn't relevant. Mostly user prompts and making arrays. To explain a little what is going on, conos() is an array containing the values of a specific column. Based on a segment of the filename, it searches for the code in the array, to get its index, which corresponds to the row.
If there isn't a Match it triggers the error. That just means there is a file, but no contact to send it to. It should skip to NoContact and create a list of these files.
So with my files, the first has a contact and generates the email, the second does not and skips to NoContact and adds the file to the list. Five more run with contacts and then it gets to another that should go to NoContact, but Unable to get the Match property of the WorksheetFunction class comes up.
It seems the error isn't getting cleared from the first one. Not sure why.
For Each objFile In objFolder.Files
wbName = objFile.Name
' Get the cono along with handling for different extensions
wbName = Replace(wbName, ".xlsx", "")
wbName = Replace(wbName, ".xlsm", "")
wbName = Replace(wbName, ".xls", "")
' Split to get just the cono
fileName() = Split(wbName, "_")
cono = fileName(2)
' Create the cell look up
c = Cells(1, WorksheetFunction.Match("Cono", cols(), 0)).Column
' ******************** ISSUE IS HERE ***************************
On Error GoTo NoContact
r = Cells(WorksheetFunction.Match(cono, conos(), 0), c).Row
Cells(r, c).Select
' Fill the variables
email = Cells(r, c).Offset(0, 1).Value
firstName = Cells(r, c).Offset(0, 3).Value
lastName = Cells(r, c).Offset(0, 4).Value
account = Cells(r, c).Offset(0, -2).Value
username = Cells(r, c).Offset(0, 6).Value
password = Cells(r, c).Offset(0, 7).Value
fPassword = Cells(r, c).Offset(0, 8).Value
' Mark as completed
Cells(r, c).Offset(0, 9).Value = "X"
' Set the object variables
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Body of the email
str = "Hi " & firstName & "," & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
' Parameters of the email
On Error Resume Next
With OutMail
.To = email
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = str
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
End With
On Error GoTo 0
' Based on the user prompts, whether or not the emails will be sent without checking them first
If finalCheck = vbYes Then
OutMail.Send
Else
OutMail.Display
End If
NoContact:
' Determiine which files don't have a corresponding email and add to list
If email = Empty Then
If conoB <> "" Then
conoB = conoB & ", " & cono
Else
conoB = cono
End If
End If
Err.Clear
' Clear variables for next use
Set OutMail = Nothing
Set OutApp = Nothing
cono = Empty
email = Empty
firstName = Empty
lastName = Empty
account = Empty
username = Empty
password = Empty
fPassword = Empty
Next:
Err.Clear just clears the information regarding the last error from the Err object - it does not exit out of error handling mode.
If an error is detected and your On Error GoTo NoContact is invoked, your code jumps down to the NoContact label, and then finally finds it way back to the start of your For Each objFile In objFolder.Files loop while still in error-handling mode.
If another error occurs while still in error-handling mode, VBA throws the error as it can no longer trap it.
You should structure your code along the lines of
For Each objFile In objFolder.Files
'...
On Error GoTo NoContactError
'...
NoContact:
'...
Next
'...
Exit Sub
NoContactError:
'Error handling goes here if you want it
Resume NoContact
End Sub
But, as Tim Williams, commented - it is much better to avoid situations that require On Error error-handling whenever possible.
I am attempting to run through sheet 2 of an Excel workbook to email ranges to customers.
The ranges would be A1:B30,C1:D30,E1:F30 and so on with their account number in A1 & email in B1 and information below.
Every time I try to run the email it comes up with:
Run Time Error 1004
and then goes on to error
Object has been moved or deleted
Is there another way of emailing ranges or a way to amend this code?
Sub EmailRanges()
Dim cr As Range
Set cr = [b1]
ActiveWorkbook.EnvelopeVisible = True
Do While cr <> ""
cr.Offset(, -1).Resize(30, 2).Select
With ActiveSheet.MailEnvelope
.Introduction = " Good Morning"
.Item.To = cr
.Item.Subject = "Just testing, sorry for filling you inbox ^_^ "
.item.Send ' to send
.Item.Display ' to test
End With
MsgBox cr & " receives " & Selection.Address
Set cr = cr.Offset(, 2)
Loop
Application.ScreenUpdating = True
MsgBox "The Customers Have Been Notified"
End Sub
You need to be more explicit about your references (workbook, sheet, ...).
Thx to #Ralph :
A range can be only selected if the sheet is activated first. Otherwise, you'll get an error.
This run smoothly on my computer :
Sub Email_Ranges()
Dim rG As Range
Dim RangeToSend As Range
Dim CustomerMail As String
Set rG = ActiveWorkbook.ActiveSheet.[b1]
ActiveWorkbook.EnvelopeVisible = True
Do While rG.Value <> vbNullString
CustomerMail = rG.Value
Set RangeToSend = rG.Offset(, -1).Resize(30, 2)
'With RangeToSend.Parent.MailEnvelope
''Uncomment below if you get an error
rG.Parent.Activate
RangeToSend.Select
With Selection.Parent.MailEnvelope
.Introduction = "Good Morning"
With .Item
.To = CustomerMail
.Subject = "Just testing, sorry for filling your inbox ^_^ "
.display 'to test
.Send 'to send
End With
End With
Debug.Print CustomerMail & " receives " & RangeToSend.Address
Set rG = rG.Offset(, 2)
Loop
ActiveWorkbook.EnvelopeVisible = False
End Sub
I was curious if anybody could provide suggestions on how I can make an excel macro more stable.
The macro prompts the user for a path to a folder containing files to scan. The macro then iterates for every file in this folder.
It opens the excel file, scans Column D for the word fail, then copies that row of data to the data sheet in the excel file where this macro is programmed.
For the most part the macro runs perfectly but sometimes I get run time errors or 'excel has stopped working' errors. I can scan through 5000+ files at a time and the macro takes a while to run.
Any suggestions would be appreciated. Thanks!
Sub findFail()
Dim pathInput As String 'path to file
Dim path As String 'path to file after being validated
Dim fileNames As String 'path to test file
Dim book As Workbook 'file being tested
Dim sheet As Worksheet 'sheet writting data to
Dim sh As Worksheet 'worksheet being tested
Dim dataBook As Workbook 'where data is recorded
Dim row As Long 'row to start writting data in
Dim numTests As Long 'number of files tested
Dim j As Long 'counter for number of files tested
Dim i As Long 'row currently being tested
Dim lastRow As Long 'last row used
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Application.ScreenUpdating = False
j = 0
i = 1
row = 2
Set dataBook = ActiveWorkbook
Set sheet = Worksheets("Data")
sheet.Range("A2:i1000").Clear
startTime = Timer
'-----Prompt for Path-----
pathInput = InputBox(Prompt:="Enter path to files. It must have a \ after folder name.", _
Title:="Single Report", _
Default:="C:\Folder\")
If pathInput = "C:\Folder\" Or pathInput = vbNullString Then 'check to make sure path was inputed
MsgBox ("Please enter a valid file path and try again.")
Exit Sub
Else
path = pathInput 'path = "C:\Temp\212458481\" ' Path for file location
fileNames = Dir(path & "*.xls") 'for xl2007 & "*.xls?" on windows
'-----begin testing-----
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
lastRow = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).row
If sh.Cells(lastRow, 2).Value - sh.Cells(1, 2).Value >= 0.08333333 Then
Do While sh.Range("D" & i).Value <> "" 'loop untile there are no rows left to test
If sh.Range("D" & i).Value = "Fail" Then 'record values if test result is false
sheet.Range("A" & row).Value = book.Name
sheet.Range("B" & row).Value = Format(sh.Range("B" & i).Value - sh.Range("B1").Value, "h:mm:ss")
sheet.Range("C" & row).Value = sh.Range("A" & i).Value
sheet.Range("D" & row).Value = Format(sh.Range("B" & i).Value, "h:mm:ss")
sheet.Range("E" & row).Value = sh.Range("C" & i).Value
sheet.Range("F" & row).Value = sh.Range("D" & i).Value
sheet.Range("G" & row).Value = sh.Range("E" & i).Value
sheet.Range("H" & row).Value = sh.Range("F" & i).Value
sheet.Range("I" & row).Value = sh.Range("G" & i).Value
row = row + 1
Exit Do
End If
i = i + 1
Loop
j = j + 1
dataBook.Sheets("Summary").Cells(2, 1).Value = j
End If
book.Close SaveChanges:=False
fileNames = Dir()
i = 1
Loop
numTests = j
Worksheets("Summary").Cells(2, "A").Value = numTests
minsElapsed = Timer - startTime
Worksheets("Summary").Cells(2, "B").Value = Format(minsElapsed / 86400, "hh:mm:ss")
End If
End Sub
Without the same dataset as you we, can not definitively supply an answer but I can recommend the below which is related to the error you are seeing.
Try freeing/destroying the references to book and sh.
You have a loop that sets them:-
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
However the end of the loop does not clear them, ideally it should look as below:-
Set sh = Nothing
Set book = Nothing
Loop
This is a better way to handle resources and should improve memory usage.
As a poor example, without it your code is saying, sh equals this, now it equals this instead, now it equals this instead, now it equals this instead, etc...
You end up with the previous reference that was subsequently overwritten being a sort of orphaned object that is holding some space in memory.
Depending on your case, you may use the following to make it faster -by turning off excel processes that you don't really need at the time of your macro execution-
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.StatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
End Sub
In your sub
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Call ExcelBusy
...
As a comment, you never set back screenupdating to true in your sub, that may lead to strange behavior in excel, you should turn everything to default after you are done with your stuff.
OT: Some processes can't be optimized any further -sometimes-, by what you are saying -scanning over 5k files?- surely it's going to take a time, you need to work in how to communicate the user that is going to take a while instead -perhaps an application status bar message or a user form showing process?-.
I have some undeliverable emails in a folder. I am trying to go through each email in the folder and pull out the intended recipients email address by searching the message.
I have some VBA code that works on regular emails, but since undeliverable's aren't Outlook "Mail Items", they are Outlook "Report Items", I am having issues searching the message. The search function is coming back empty and after a lot of research, it seems that maybe "Report Items" do not actually have a "body" that can be searched.
The email in all the error reports are in the following format in the report.
(xxxxxx#xxxxxx.com)
Here is the code I am using, which works on normal Mail Items.
Sub Undeliver()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
'Selects the current active folder to use
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
'creates excel spreadsheet where data will go
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
'names column a row 1 "email" and column b row 1 "else"
xlobj.Range("a" & 1).Value = "Email"
xlobj.Range("b" & 1).Value = "Else"
'loops through all the items in the current folder selected
For I = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(I)
'selects the body of the current email being searched
msgtext = myitem.Body
'searches the body for the first open parentheses and first close
'parentheses and copies the value in between into an array
delimtedMessage = Replace(msgtext, "(", "###")
delimtedMessage = Replace(delimtedMessage, ")", "###")
'splits the array up into two pieces
messageArray = Split(delimitedMessage, "###")
'this inputs the values of the array into my excel spreadsheet
xlobj.Range("a" & I + 1).Value = messageArray(1)
xlobj.Range("b" & I + 1).Value = messageArray(2)
Next I
End Sub
Does anyone know how I can access the message part of the report for searching purposes?
The solution I ended up going with involved converting the body of the message back to Unicode and then searching for what I needed. This ended up being very simple to implement.
Here is my finished, working code for future reference. I ended up adding a progress bar to monitor where it was in the code. It unfortunately runs fairly slow but it gets the job done.
Hopefully this helps someone in the future!
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
xlobj.Range("a" & 1).Value = "Email"
xlobj.Application.displayStatusBar = True
For I = 1 To myOlApp.ActiveExplorer.CurrentFolder.Items.Count
Set myitem = myOlApp.ActiveExplorer.CurrentFolder.Items(I)
msgtext = StrConv(myitem.Body, vbUnicode)
delimtedMessage = Replace(msgtext, "mailto:", "###")
delimtedMessage = Replace(delimtedMessage, "</a><br>", "###")
messageArray = Split(delimtedMessage, "###")
xlobj.Range("a" & I + 1).Value = Split(messageArray(1), """")(0)
xlobj.Application.StatusBar = "Progress: " & I & " of " & myOlApp.ActiveExplorer.CurrentFolder.Items.Count & Format(I / myOlApp.ActiveExplorer.CurrentFolder.Items.Count, " 0%")
Next I
xlobj.Application.displayStatusBar = False
Well, there is always this solution.
The gist is that ReportItem.Body returns an unreadable string, so this solution saves the ReportItem as a text file, then parses the text file. Its not exactly elegant, but it should work.
Hope this helps!
This is the code I use to dynamically create charts in Virtual Basic:
Dim Chart As Object
Set Chart = Charts.Add
With Chart
If bIssetSourceChart Then
CopySourceChart
.Paste Type:=xlFormats
End If
For Each s In .SeriesCollection
s.Delete
Next s
.ChartType = xlColumnClustered
.Location Where:=xlLocationAsNewSheet, Name:=chartTitle
Sheets(chartTitle).Move After:=Sheets(Sheets.count)
With .SeriesCollection.NewSeries
If Val(Application.Version) >= 12 Then
.values = values
.XValues = columns
.Name = chartTitle
Else
.Select
Names.Add "_", columns
ExecuteExcel4Macro "series.columns(!_)"
Names.Add "_", values
ExecuteExcel4Macro "series.values(,!_)"
Names("_").Delete
End If
End With
End With
#The CopySourceChart Sub:
Sub CopySourceChart()
If Not CheckSheet("Source chart") Then
Exit Sub
ElseIf TypeName(Sheets("Grafiek")) = "Chart" Then
Sheets("Grafiek").ChartArea.Copy
Else
Dim Chart As ChartObject
For Each Chart In Sheets("Grafiek").ChartObjects
Chart.Chart.ChartArea.Copy
Exit Sub
Next Chart
End If
End Sub
How can I keep the formatting of series that is applied in the If bIssetSourceChart part while deleting those series' data?
I have solved this issue before. I have charts that were created by macro but it only applied to the date I made them. So a made a refresh macro that runs after every Workbook open. I used source before and found that it deletes everything. then moved on to series only. I will paste my work here and try to explain. For quick navigation the second part of the code down there called sub aktualizacegrafu() might help you if you get lost find a reference in upper part of the code starting with sub generacegrafu()
Sub generacegrafu()
ThisWorkbook.Sheets("List1").CommandButton6.BackColor = &H0&
ThisWorkbook.Sheets("List1").CommandButton6.ForeColor = &HFFFFFF
Dim najdiposlradek As Object
Dim graf As Object
Dim vkladacistring As String
Dim vykreslenysloupec As Integer
Dim hledejsloupec As Object
Dim hledejsloupec2 As Object
Dim kvantifikator As Integer
Dim grafx As ChartObject
Dim shoda As Boolean
Dim jmenografu As String
Dim rngOrigSelection As Range
Cells(1, 1).Select
If refreshcharts = True Then
Set hledejsloupec = Range("11:11").Find(What:=prvnislovo, LookIn:=xlValues)
'dynamicaly generated, prvnislovo is for first word in graph and the macro looks for match in row 11 if it doesnt find any then
Else
'then it looks for match in option box
Set hledejsloupec = Range("11:11").Find(What:=ThisWorkbook.Sheets("List1").ComboBox1.Value, LookIn:=xlValues)
End If
If hledejsloupec Is Nothing Then
MsgBox "Zadaný sloupec v první nabídce nebyl nalezen."
Else
If refreshcharts = True Then
Set hledejsloupec2 = Range("11:11").Find(What:=druheslovo, LookIn:=xlValues)
Else
Set hledejsloupec2 = Range("11:11").Find(What:=ThisWorkbook.Sheets("List1").ComboBox2.Value, LookIn:=xlValues)
End If
If hledejsloupec2 Is Nothing Then
MsgBox "Zadaný sloupec v druhé nabídce nebyl nalezen."
Else
jmenografu = Cells(11, hledejsloupec.Column).Value & "_" & Cells(11, hledejsloupec2.Column).Value
Set najdiposlradek = Range("A:A").Find(What:=Date, LookIn:=xlValues)
Application.ScreenUpdating = False
Set rngOrigSelection = Selection
'This one selects series for new graph to be created
Cells(1048576, 16384).Select
Set graf = ThisWorkbook.Sheets("List1").Shapes.AddChart
rngOrigSelection.Parent.Parent.Activate
rngOrigSelection.Parent.Select
rngOrigSelection.Select 'trouble with annoing excel feature to unselect graphs
Application.ScreenUpdating = True
graf.Select
kvantifikator = 1
Do
shoda = False
For Each grafx In ThisWorkbook.Sheets("List1").ChartObjects
If grafx.Name = jmenografu Then
shoda = True
jmenografu = jmenografu & "(" & kvantifikator & ")"
kvantifikator = kvantifikator + 1
End If
Next grafx
'this checks if graph has younger brother in sheet
'but no we get to the part that matter do not bother playing with source of the graph because I have found it is quite hard to make it work properly
Loop Until shoda = False
'here it starts
ActiveChart.Parent.Name = jmenografu
ActiveChart.SeriesCollection.NewSeries 'add only series!
vkladacistring = "=List1!R12C" & hledejsloupec.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec.Column 'insert this into series
ActiveChart.SeriesCollection(1).Values = vkladacistring
vkladacistring = "=List1!R11C" & hledejsloupec.Column
ActiveChart.SeriesCollection(1).Name = vkladacistring
vkladacistring = "=List1!R12C" & hledejsloupec2.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec2.Column
ActiveChart.SeriesCollection(1).XValues = vkladacistring
'here it ends and onward comes formating
ActiveChart.Legend.Delete
ActiveChart.ChartType = xlConeColClustered
ActiveChart.ClearToMatchStyle
ActiveChart.ChartStyle = 41
ActiveChart.ClearToMatchStyle
ActiveSheet.Shapes(jmenografu).Chart.ChartArea.Format.ThreeD.RotationY = 90
ActiveSheet.Shapes(jmenografu).Chart.ChartArea.Format.ThreeD.RotationX = 0
ActiveChart.Axes(xlValue).MajorUnit = 8.33333333333333E-02
ActiveChart.Axes(xlValue).MinimumScale = 0.25
ActiveChart.Walls.Format.Fill.Visible = msoFalse
ActiveChart.Axes(xlCategory).MajorUnitScale = xlMonths
ActiveChart.Axes(xlCategory).MajorUnit = 1
ActiveChart.Axes(xlCategory).BaseUnit = xlDays
End If
End If
Call aktualizacelistboxu
ThisWorkbook.Sheets("List1").CommandButton6.BackColor = &H8000000D
ThisWorkbook.Sheets("List1").CommandButton6.ForeColor = &H0&
End Sub
the result i found is that you cannot keep formating completely when you close chart because source of chart doesnt work very well and when you delete it some format will be lost
I will post my actualization of chart as well
Sub aktualizacegrafu()
Dim grafx As ChartObject
Dim hledejsloupec As Object
Dim hledejsloupec2 As Object
Dim vkladacistring As String
Dim najdiposlradek As Object
For Each grafx In ThisWorkbook.Sheets("List1").ChartObjects
prvnislovo = Left(grafx.Name, InStr(1, grafx.Name, "_") - 1)
druheslovo = Right(grafx.Name, Len(grafx.Name) - InStr(1, grafx.Name, "_"))
'now it checks the names of charts .. the data loads from respective columns that are named the same way so I ussualy choose what statistic I want by choosing the columns needed
'for example I want to reflect my arrivals to work according to the hours I worked or to the date so I set 1st option to arrival and 2nd to date
grafx.Activate
Set najdiposlradek = Range("A:A").Find(What:=Date, LookIn:=xlValues)
Set hledejsloupec = Range("11:11").Find(What:=prvnislovo, LookIn:=xlValues)
If hledejsloupec Is Nothing Then
MsgBox "Hodnota v grafu již není mezi sloupci v tabulce. Aktualizace grafu " & grafx.Name & " bude ukončena."
Else
Set hledejsloupec2 = Range("11:11").Find(What:=druheslovo, LookIn:=xlValues)
If hledejsloupec2 Is Nothing Then
MsgBox "Hodnota v grafu již není mezi sloupci v tabulce. Aktualizace grafu " & grafx.Name & " bude ukončena."
Else
here it enters string that contains adress of desired cell I always enter it as string cause its easier to see with debug.print what is being entered
result looks like this List means Sheet in czech
activechart.seriescollection(1).values=List1!R12C1:R13C16
activechart.seriescollection(1).name=List1!R1C1:R1C15
vkladacistring = "=List1!R12C" & hledejsloupec.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec.Column
ActiveChart.SeriesCollection(1).Values = vkladacistring
vkladacistring = "=List1!R11C" & hledejsloupec.Column
ActiveChart.SeriesCollection(1).Name = vkladacistring
vkladacistring = "=List1!R12C" & hledejsloupec2.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec2.Column
ActiveChart.SeriesCollection(1).XValues = vkladacistring
End If
End If
Next grafx
Call aktualizacelistboxu
End Sub
so result of this is when you actually have a chart already but want to make slight changes to the area it applies to then it keeps the formating
hope this helped a bit if not I am sorry if it did keep the revard. It just got me curious because I was solving the same problem recently
if you need any further explanation comment this and I will try to explain