Let's start with an example of how some values in my workbook look like:
A B C
1 14-001 2014G001
2 14-002 2014G002
3 14-001 2014I002
I want to make a script that copies the values in column B to C, and combines the last 4 characters of these values if the cell value in column A are the same. after running the script it should look like:
A B C
1 14-001 2014G001 G001/I001
2 14-002 2014G002 G002
3 14-001 2014I001
I never had to look for duplicates and I can't find a similar problem on the net. Can somebody help me out?
Thanks!!
I actually worked it out myself :) Now I have to find out how to change it when there are 3 of the same..Somebody?
Sub test()
Dim toAdd As Boolean, uniqueNumbers As Integer, i As Integer, j As Integer
Dim A$, B$
Cells(1, 4).Value = Cells(1, 1).Value
Cells(1, 5).Value = Cells(1, 2).Value
uniqueNumbers = 1
toAdd = True
For i = 2 To 30
For j = 1 To uniqueNumbers
If Cells(i, 1).Value = Cells(j, 4).Value Then
toAdd = False
A = Right(Cells(i, 2), 4)
B = Right(Cells(j, 2), 4)
Cells(j, 5).Value = A & " / " & B
End If
Next j
If toAdd = True Then
Cells(uniqueNumbers + 1, 4).Value = Cells(i, 1).Value
Cells(uniqueNumbers + 1, 5).Value = Cells(i, 2).Value
uniqueNumbers = uniqueNumbers + 1
End If
toAdd = True
Next i
End Sub
Related
Hello i want to ask about some problem about excel, i have some data like this:
and i have import that JSON data to excel with modules from https://github.com/TheEricBurnett/Excellent-JSON
and my code form are
Private Sub ImportJSONFIle_Click()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select a JSON File"
.AllowMultiSelect = False
If .Show() Then
Filename = .SelectedItems(1)
Dim content As String
Dim iFile As Integer: iFile = FreeFile
Open Filename For Input As #iFile
content = Input(LOF(iFile), iFile)
' Parse JSON String
Dim dummyData As Object
Set dummyData = JsonConverter.ParseJson(content)
i = 1
For Each dummyDatas In dummyData
Cells(i, 1) = dummyDatas("nama")
Cells(i, 2) = dummyDatas("email")
i = i + 1
Next
Close #iFile
End If
End With End Sub
finally the result is:
Here i want to ask how to make the data written horizontally not vertically? Here the result what i want :
Since you could potentially deal with alot of entries from the JSON, it is recommended to populate the values in an array first then write into your worksheet.
Replace this:
For Each dummyDatas In dummyData
Cells(i, 1) = dummyDatas("nama")
Cells(i, 2) = dummyDatas("email")
i = i + 1
Next
To this:
Dim outputArr() As Variant
ReDim outputArr(1 To 1, 1 To dummyData.Count * 2) As Variant
For Each dummyDatas In dummyData
outputArr(1, i) = dummyDatas("nama")
i = i + 1
outputArr(1, i) = dummyDatas("email")
i = i + 1
Next
Cells(1, 1).Resize(, UBound(outputArr, 2)).Value = outputArr
EDIT - To insert result after the last column
Dim outputArr() As Variant
ReDim outputArr(1 To 1, 1 To dummyData.Count * 2) As Variant
For Each dummyDatas In dummyData
outputArr(1, i) = dummyDatas("nama")
i = i + 1
outputArr(1, i) = dummyDatas("email")
i = i + 1
Next
Dim lastCol As Long
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(1, lastCol + 1).Resize(, UBound(outputArr, 2)).Value = outputArr
You may try to replace :
Cells(i, 1) = dummyDatas("nama")
Cells(i, 2) = dummyDatas("email")
with
Cells(1,i) = dummyDatas("nama")
i=i+1
Cells(1,i) = dummyDatas("email")
Not tested but this should work. Replace this:
Cells(i, 1) = dummyDatas("nama")
Cells(i, 2) = dummyDatas("email")
i = i + 1
With:
Cells(1, i) = dummyDatas("nama")
Cells(1, i+1) = dummyDatas("email")
i=i+2
I have been parsing data from JSON to Excel and the code is working fine but it takes much time to write data which is more than 1 minute.
Every Column has 5K rows of data. I have searched to find better way of parsing data into excel with less time but no success.
I do hope there will be an way of achieving this. Any help will be much appreciated
Sub parsejson()
Dim t As Single
t = Timer
Dim objRequest As Object
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Dim idno, r As Long
Dim ws, ws2 As Worksheet
Dim JSON As Object
Dim lrow As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Set ws = Sheet1
Set ws2 = Sheet2
Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = ""
blnAsync = True
With objRequest
.Open "GET", strUrl, blnAsync
.setRequestHeader "Content-Type", "application/json"
.send
While objRequest.readyState <> 4
DoEvents
Wend
strResponse = .ResponseText
End With
Dim resultDict As Object
Set resultDict = ParseJson("{""result"":" & strResponse & "}")
Dim i As Long
Dim resultNum As Long
resultNum = resultDict("result").Count
r = 2
For i = 1 To resultNum
ws.Cells(r, "B").Value = resultDict("result")(i)("productName")
ws.Cells(r, "C").Value = resultDict("result")(i)("upc")
ws.Cells(r, "D").Value = resultDict("result")(i)("asin")
ws.Cells(r, "E").Value = resultDict("result")(i)("epid")
ws.Cells(r, "G").Value = resultDict("result")(i)("platform")
ws.Cells(r, "I").Value = resultDict("result")(i)("uniqueID")
ws.Cells(r, "L").Value = resultDict("result")(i)("productShortName")
ws.Cells(r, "M").Value = resultDict("result")(i)("coverPicture")
ws.Cells(r, "N").Value = resultDict("result")(i)("realeaseYear")
ws.Cells(r, "Q").Value = resultDict("result")(i)("verified")
ws.Cells(r, "S").Value = resultDict("result")(i)("category")
ws2.Cells(r, "E").Value = resultDict("result")(i)("brand")
ws2.Cells(r, "F").Value = resultDict("result")(i)("compatibleProduct")
ws2.Cells(r, "G").Value = resultDict("result")(i)("type")
ws2.Cells(r, "H").Value = resultDict("result")(i)("connectivity")
ws2.Cells(r, "I").Value = resultDict("result")(i)("compatibleModel")
ws2.Cells(r, "J").Value = resultDict("result")(i)("color")
ws2.Cells(r, "K").Value = resultDict("result")(i)("material")
ws2.Cells(r, "L").Value = resultDict("result")(i)("cableLength")
ws2.Cells(r, "M").Value = resultDict("result")(i)("mpn")
ws2.Cells(r, "O").Value = resultDict("result")(i)("features")
ws2.Cells(r, "Q").Value = resultDict("result")(i)("wirelessRange")
ws2.Cells(r, "T").Value = resultDict("result")(i)("bundleDescription")
r = r + 1
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
MsgBox "RunTime : " & Format((Timer - t) / 86400, "hh:mm:ss")
End Sub
As already discussed, your code is not slow because of parsing the JSON, but because you write every value cell by cell. The interface between VBA and Excel is slow compared to things done in memory, so the way to go is to write the data into a 2-dimensional array that can be written all at once into Excel.
As the destination in Excel is not a single Range, I suggest to have a small routine that collects and writes data for one column. Easy to understand and easy to adapt if columns or field names changes.
Sub writeColumn(destRange As Range, resultDict As Object, colName As String)
Dim resultNum As Long, i As Long
resultNum = resultDict("result").Count
' Build a 2-dimesional array. 2nd index is always 1 as we write only one column.
ReDim columnData(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
columnData(i, 1) = resultDict("result")(i)(colName)
Next
' Write the data into the column
destRange.Cells(1, 1).Resize(resultNum, 1) = columnData
End Sub
For every field/column, you need a call in your main routine (but without any loop)
Call writeColumn(ws.Cells(r, "B"), resultDict, "productName")
(...)
Call writeColumn(ws2.Cells(r, "E"), resultDict, "brand")
(...)
Writing/Reading value to/from cell is a very slow operation, even more so when you are doing that so many times in a row therefore populating your data in an array and write into the cells in blocks is the best way.
Since your requirement involves multiple continuous range, you will have to write into the sheet multiple times.
Replace your entire For loop with the below code, not the prettiest but should work:
Dim dataArr() As Variant
ReDim dataArr(1 To resultNum, 1 To 4) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("productName")
dataArr(i, 2) = resultDict("result")(i)("upc")
dataArr(i, 3) = resultDict("result")(i)("asin")
dataArr(i, 4) = resultDict("result")(i)("epid")
Next i
ws.Range(ws.Cells(2, "B"), ws.Cells(1 + resultNum, "E")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("platform")
Next i
ws.Range(ws.Cells(2, "G"), ws.Cells(1 + resultNum, "G")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("uniqueID")
Next i
ws.Range(ws.Cells(2, "I"), ws.Cells(1 + resultNum, "I")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 3) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("productShortName")
dataArr(i, 2) = resultDict("result")(i)("coverPicture")
dataArr(i, 3) = resultDict("result")(i)("realeaseYear")
Next i
ws.Range(ws.Cells(2, "L"), ws.Cells(1 + resultNum, "N")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("verified")
Next i
ws.Range(ws.Cells(2, "Q"), ws.Cells(1 + resultNum, "Q")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("category")
Next i
ws.Range(ws.Cells(2, "S"), ws.Cells(1 + resultNum, "S")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 9) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("brand")
dataArr(i, 2) = resultDict("result")(i)("compatibleProduct")
dataArr(i, 3) = resultDict("result")(i)("type")
dataArr(i, 4) = resultDict("result")(i)("connectivity")
dataArr(i, 5) = resultDict("result")(i)("compatibleModel")
dataArr(i, 6) = resultDict("result")(i)("color")
dataArr(i, 7) = resultDict("result")(i)("material")
dataArr(i, 8) = resultDict("result")(i)("cableLength")
dataArr(i, 9) = resultDict("result")(i)("mpn")
Next i
ws2.Range(ws2.Cells(2, "E"), ws2.Cells(1 + resultNum, "M")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 2) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("features")
dataArr(i, 2) = resultDict("result")(i)("wirelessRange")
Next i
ws2.Range(ws2.Cells(2, "O"), ws2.Cells(1 + resultNum, "Q")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("bundleDescription")
Next i
ws2.Range(ws2.Cells(2, "T"), ws2.Cells(1 + resultNum, "T")).Value = dataArr
It's been years since I last had to code anything, but now I seem to need it again.
To simplify, I have number 7 in column A, and I need to input another number in column B depending on what number 7 relates to in another table in another sheet.
So in Sheet2 another table has numbers ranging from 1 to 10 in column A, and according numbers in column B. I then need it to search for number 7 in column A of sheet2 and give me the number in column B, and place it in column B in the first sheet.
I have tried a For loop inside a For loop, based on another code I found somewhere, but it's been so long ago I would need to spend hours rereading and trying to get near a solution. Maybe this is an easy thing for advanced coders?
Anyways, thanks in advance for the help!
couldn't you ever help without VBA then you can use this
Option Explicit
Sub main()
Dim cell As Range, f As Range
Dim rng1 As Range, rng2 As Range
Set rng1 = Worksheets("Sht1").Columns(1).SpecialCells(xlCellTypeConstants) '<--Change "Sht1" to your actual sheet1 name
Set rng2 = Worksheets("Sht2").Columns(1).SpecialCells(xlCellTypeConstants) '<--Change "Sht2" to your actual sheet2 name
For Each cell In rng1
Set f = rng2.Find(what:=cell.Value2, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=xlNo)
If Not f Is Nothing Then cell.Offset(, 1) = f.Offset(, 1)
Next cell
End Sub
Here are two ways of doing searching over two tables.
Sub LoopValues()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim sourceLastRow As Long, searchLastRow As Long
Dim i As Long, j As Long
Set wsSource = Worksheets("Sheet3")
Set wsSearch = Worksheets("Sheet4")
With wsSource
sourceLastRow = .Range("A" & Rows.Count).End(xlUp).Row
searchLastRow = wsSearch.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To sourceLastRow
For j = 2 To sourceLastRow
If .Cells(i, 1).Value = wsSearch.Cells(j, 1).Value Then .Cells(i, 2).Value = wsSearch.Cells(j, 2).Value
Next
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub FindValuesLoop()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim sourceLastRow As Long
Dim i As Long
Dim SearchRange As Range, rFound As Range
Set wsSource = Worksheets("Sheet3")
Set wsSearch = Worksheets("Sheet4")
With wsSource
sourceLastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set SearchRange = wsSearch.Range(wsSearch.Range("A1"), wsSearch.Range("A" & Rows.Count).End(xlUp))
For i = 2 To sourceLastRow
Set rFound = SearchRange.Find(What:=.Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then .Cells(i, 2).Value = rFound.Offset(0, 1).Value
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I have code that takes fields from a MS Access form and copies the data into a saved Excel file. The first record in Access in imported to Excel with a range of A2:I2. The second record in Access is imported to Excel with a range of A3:I3, and so on.... What currently happens now is if I close my form in Access and open it back up, and say I already had two records imported into this same Excel file, and now I want to add a third record, it will start over at the first row (A2:I2) and write over what is already there. My question is how can I, if I close and open Access keep it from starting over on (A2:I2), and instead start at the next available row, which to follow the example given would be (A4:I4)? This is the code I have
Private Sub Command73_Click()
Set objXLApp = CreateObject("Excel.Application")
Set objXLBook = objXLApp.Workbooks.Open("Y:\123files\Edmond\Hotel Reservation Daily.xls")
objXLApp.Application.Visible = True
With objXLBook.ActiveSheet
Set r = .usedRange
i = r.Rows.Count + 1
.Cells(i + 1, 1).Value = Me.GuestFirstName & " " & GuestLastName
.Cells(i + 1, 2).Value = Me.PhoneNumber
.Cells(i + 1, 3).Value = Me.cboCheckInDate
.Cells(i + 1, 4).Value = Me.cboCheckOutDate
.Cells(i + 1, 5).Value = Me.GuestNo
.Cells(i + 1, 6).Value = Me.RoomType
.Cells(i + 1, 7).Value = Me.RoomNumber
.Cells(i + 1, 8).Value = Date
.Cells(i + 1, 9).Value = Me.Employee
End With
Set r = Nothing
Set objXLBook = Nothing
Set objXLApp = Nothing
End Sub
You can get the last used row:
Set r = objXLBook.ActiveSheet.UsedRange
i = r.Rows.Count + 1
Some notes.
Private Sub Command73_Click()
''It is always a good idea to put sensible names on command buttons.
''It may not seem like much of a problem today, but it will get there
Dim objXLApp As Object
Dim objXLBook As Object
Dim r As Object
Dim i As Integer
''It is nearly always best to check whether Excel is open before
''opening another copy.
Set objXLApp = CreateObject("Excel.Application")
Set objXLBook = objXLApp.Workbooks.Open( _
"Y:\123files\Edmond\Hotel Reservation Daily.xls")
objXLApp.Application.Visible = True
''It is generally best to specify the sheet
''With objXLBook.ActiveSheet
With objXLBook.Sheets("Room Reservation")
''If the used range includes empty rows
''it may not suit
''Set r = .UsedRange
''i = r.Rows.Count + 1
''From comments, it appears that the data is dense
''but with a number of empty rows at the end of the sheet
i = .Range("A1").End(xlDown).Row + 1
.Cells(i, 1).Value = Me.GuestFirstName & " " & GuestLastName
.Cells(i, 2).Value = Me.PhoneNumber
.Cells(i, 3).Value = Me.cboCheckInDate
.Cells(i, 4).Value = Me.cboCheckOutDate
.Cells(i, 5).Value = Me.GuestNo
.Cells(i, 6).Value = Me.RoomType
.Cells(i, 7).Value = Me.RoomNumber
.Cells(i, 8).Value = Date
.Cells(i, 9).Value = Me.Employee
End With
''Tidy up
Set objXLBook = Nothing
Set objXLApp = Nothing
End Sub
You might also like to look at TransferSpreadsheet.
Another possibility is to use the RecordsetClone, for data from a form, or any recordset, for that matter. It does not give quite the same control, but it is very fast:
Dim objXLApp As Object
Dim objXLBook As Object
Dim r As Object
Dim i As Integer
Dim rs As DAO.Recordset
Set objXLApp = CreateObject("Excel.Application")
objXLApp.Visible = True
Set objXLBook = objXLApp.Workbooks.Open( _
"Y:\123files\Edmond\Hotel Reservation Daily.xls")
Set rs = Me.RecordsetClone
With objXLBook.Sheets("Sheet1")
Set r = .UsedRange
i = r.Rows.Count + 1
.Cells(i, 1).CopyFromRecordset rs
End With
So I have some VBA for taking charts built with the Form's Chart Wizard, and automatically inserting it into PowerPoint Presentation slides. I use those chart-forms as sub forms within a larger forms that has parameters the user can select to determine what is on the chart. The idea is that the user can determine the parameter, build the chart to his/her liking, and click a button and have it in a ppt slide with the company's background template, blah blah blah.....
So it works, though it is very bulky in terms of the amount of objects I have to use to accomplish this.
I use expressions such as the following:
like forms!frmMain.Month&*
to get the input values into the saved queries, which was fine when i first started, but it went over so well and they want so many options, that it is driving the number of saved queries/objects up. I need several saved forms with charts because of the number of different types of charts I need to have this be able to handle.
SO FINALLY TO MY QUESTION:
I would much rather do all this on the fly with some VBA. I know how to insert list boxes, and text boxes on a form, and I know how to use SQL in VBA to get the values I want from tables/queries using VBA, I just don't know if there is some vba I can use to set the data values of the charts from a resulting recordset:
DIM rs AS DAO.Rescordset
DIM db AS DAO.Database
DIM sql AS String
sql = "SELECT TOP 5 Count(tblMain.TransactionID) AS Total, tblMain.Location FROM
tblMain WHERE (((tblMain.Month) = """ & me.txtMonth & """ )) ORDER BY Count
(tblMain.TransactionID) DESC;"
set db = currentDB
set rs = db.OpenRecordSet(sql)
rs.movefirst
some kind of cool code in here to make this recordset
the data of chart in frmChart ("Chart01")
thanks for your help. apologies for the length of the explanation.
It is possible to change the dataset directly in vba as I have managed to do it. However the performance is not so good so I went back to filling the results to a temp table and basing the graph on that ( see my only asked stackoverflow question) however if the dataset is quite small then you can certainly make it work. I'm not in the office but if you want code I can post on Monday
EDIT: here is the old code module I used. This is the full thing but the key part you are going to be looking at is the part about opening the datasheet of the graph and then changing the value of it like this .cells(1,0)="badger".
I enevtly dumped this method and went with a temp table as in my app the graph is redraw quite a lot and I needed to go for the fastest possible method to give a "real time" feel to it but it might be just fine for your needs
Public Sub Draw_graph(strGraph_type As String)
Dim objGraph As Object
Dim objDS As Object
Dim i As Byte
On Error GoTo Error_trap
Dim lRT_actual As Long
Dim lRT_forecast As Long
Dim Start_time As Long
Dim aCell_buffer(49, 4) As Variant
Me.acxProgress_bar.Visible = True
Me.acxProgress_bar.Value = 0
Set objGraph = Me.oleCall_graph.Object
Set objDS = objGraph.Application.datasheet
Start_time = GetTime()
With objDS
.cells.Clear
Select Case strGraph_type
Case Is = "Agents"
'**************************
'** Draw the agent graph **
'**************************
.cells(1, 1) = "Start Time"
.cells(1, 2) = "Provided"
.cells(1, 3) = "Required"
.cells(1, 4) = "Actual Required"
For i = 1 To 48
.cells(i + 1, 1) = Format(DateAdd("n", (i - 1) * 15, "08:00:00"), "HHMM")
If Me.Controls("txtAgents_pro_" & i) > 0 Then
.cells(i + 1, 2) = Me.Controls("txtAgents_pro_" & i) + Me.Controls("txtAgents_add_" & i)
Else
.cells(i + 1, 2) = 0
End If
If Me.Controls("txtAgents_req_" & i) > 0 Then
.cells(i + 1, 3) = Me.Controls("txtAgents_req_" & i)
End If
If Me.Controls("txtActual_" & i) > 0 Then
.cells(i + 1, 4) = Erlang_Agents(Me.txtServiceLevel, Me.txtServiceTime, Me.Controls("txtActual_" & i) * 4, Me.txtAVHT + CLng(Nz(Me.txtDaily_AVHT_DV, 0)))
End If
'update the progress bar
If Me.acxProgress_bar.Value + 2 < 100 Then
Me.acxProgress_bar.Value = Me.acxProgress_bar.Value + 2
Else
Me.acxProgress_bar.Value = 90
End If
Next i
Case Is = "Calls"
'**************************
'** Draw the Calls graph **
'**************************
.cells(1, 1) = "Start Time"
.cells(1, 2) = "Forecast"
.cells(1, 3) = "Actual"
For i = 1 To 48
.cells(i + 1, 1) = Format(DateAdd("n", (i - 1) * 15, "08:00:00"), "HHMM")
If Me.Controls("txtForecast_" & i) > 0 Then
.cells(i + 1, 2) = Me.Controls("txtForecast_" & i)
Else
.cells(i + 1, 2) = 0
End If
If Me.Controls("txtActual_" & i) > 0 Then
.cells(i + 1, 3) = Me.Controls("txtActual_" & i)
End If
If Me.acxProgress_bar.Value + 2 < 100 Then
Me.acxProgress_bar.Value = Me.acxProgress_bar.Value + 2
Else
Me.acxProgress_bar.Value = 90
End If
Next i
Case Is = "Call Deviation"
'**************************
'** Draw the Call Deviation graph **
'**************************
.cells(1, 1) = "Start Time"
.cells(1, 2) = "Deviation"
lRT_actual = 0
lRT_forecast = 0
For i = 1 To 48
lRT_actual = lRT_actual + Me.Controls("txtActual_" & i)
lRT_forecast = lRT_forecast + Me.Controls("txtForecast_" & i)
.cells(i + 1, 1) = Format(DateAdd("n", (i - 1) * 15, "08:00:00"), "HHMM")
.cells(i + 1, 2) = lRT_actual - lRT_forecast
If Me.acxProgress_bar.Value + 2 < 100 Then
Me.acxProgress_bar.Value = Me.acxProgress_bar.Value + 2
Else
Me.acxProgress_bar.Value = 90
End If
Next i
Case Is = "Call Deviation %"
'**************************
'** Draw the Call Deviation % graph **
'**************************
.cells(1, 1) = "Start Time"
.cells(1, 2) = "Deviation"
lRT_actual = 0
lRT_forecast = 0
For i = 1 To 48
lRT_actual = lRT_actual + Me.Controls("txtActual_" & i)
lRT_forecast = lRT_forecast + Me.Controls("txtForecast_" & i)
.cells(i + 1, 1) = Format(DateAdd("n", (i - 1) * 15, "08:00:00"), "HHMM")
If lRT_forecast > 0 Then
.cells(i + 1, 2) = (lRT_actual - lRT_forecast) / lRT_forecast
End If
If Me.acxProgress_bar.Value + 2 < 100 Then
Me.acxProgress_bar.Value = Me.acxProgress_bar.Value + 2
Else
Me.acxProgress_bar.Value = 90
End If
Next i
Case Is = "SLA"
'**************************
'*** Draw the SLA graph ***
'**************************
.cells(1, 1) = "Start Time"
.cells(1, 2) = "SLA"
.cells(1, 3) = "Actual SLA"
For i = 1 To 48
.cells(i + 1, 1) = Format(DateAdd("n", (i - 1) * 15, "08:00:00"), "HHMM")
If Me.Controls("txtSLA_" & i) > 0 Then
.cells(i + 1, 2) = Me.Controls("txtSLA_" & i) / 100
Else
.cells(i + 1, 2) = 0
End If
If Me.Controls("txtActual_SLA_" & i) > 0 Then
.cells(i + 1, 3) = Me.Controls("txtActual_SLA_" & i)
End If
If Me.acxProgress_bar.Value + 2 < 100 Then
Me.acxProgress_bar.Value = Me.acxProgress_bar.Value + 2
Else
Me.acxProgress_bar.Value = 90
End If
Next i
End Select
End With
Set objDS = Nothing
Set objGraph = Nothing
Me.acxProgress_bar.Visible = False
Exit Sub
Error_trap:
DoCmd.Hourglass False
MsgBox "An error happened in sub Draw_graph, error description, " & Err.Description, vbCritical, "Tracker 3"
End Sub
One very easy way of doing this is to base the chart on a query and update the query, for example:
strSQL = "SELECT ..."
QueryName = "qryByHospital"
If IsNull(DLookup("Name", "MsysObjects", "Name='" & QueryName & "'")) Then
CurrentDb.CreateQueryDef QueryName, strSQL
Else
CurrentDb.QueryDefs(QueryName).SQL = strSQL
End If
DoCmd.OpenReport "rptChartByHospital", acViewPreview