API tools faq
paste
Trai60

Untitled

Trai60
Nov 24th, 2024
33
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 56.90 KB | None | 0 0
raw download clone embed print report
  1. Option Explicit
  2.  
  3. Public Sub UpdateSummary()
  4. ' This macro creates the Summary sheet and pivot tables
  5. ' Run this SECOND after ProcessProlificData
  6.  
  7. Dim wsData As Worksheet
  8. Dim wsSummary As Worksheet
  9.  
  10. ' Prevent screen updating during calculations
  11. Application.ScreenUpdating = False
  12.  
  13. Application.DisplayAlerts = False
  14.  
  15. ' Check if Processed_Data exists
  16. On Error Resume Next
  17. Set wsData = ThisWorkbook.Sheets("Processed_Data")
  18. If wsData Is Nothing Then
  19. MsgBox "Processed_Data sheet not found! Run ProcessProlificData first.", vbExclamation
  20. Exit Sub
  21. End If
  22. On Error GoTo 0
  23.  
  24. ' Delete existing Summary sheet if it exists
  25. On Error Resume Next
  26. ThisWorkbook.Sheets("Summary").Delete
  27. On Error GoTo 0
  28.  
  29. ' Create new Summary sheet
  30. Set wsSummary = ThisWorkbook.Sheets.Add(After:=wsData)
  31. wsSummary.Name = "Summary"
  32.  
  33. ' Create summary sheet and pivot tables
  34. CreateSummarySheet
  35.  
  36. ' Create hourly rate data and chart
  37. TestHourlyRateCalculation
  38. CreateYearlyRateAnalysis
  39. CreateHourlyRateChartOnSummary
  40.  
  41. ' Add these lines at the end, just before End Sub
  42. Application.DisplayAlerts = True
  43. Application.ScreenUpdating = True
  44. wsSummary.Activate ' This will make the Summary sheet active
  45. ThisWorkbook.Sheets("TempData").Visible = False ' This will hide the TempData sheet
  46. End Sub
  47.  
  48. Private Sub CreateSummarySheet()
  49. Dim wsData As Worksheet
  50. Dim wsSummary As Worksheet
  51. Dim lastRow As Long
  52.  
  53. ' Reference the processed data sheet
  54. Set wsData = ThisWorkbook.Sheets("Processed_Data")
  55. Set wsSummary = ThisWorkbook.Sheets("Summary")
  56.  
  57. lastRow = wsData.Cells(wsData.Rows.count, "A").End(xlUp).row
  58.  
  59. ' Clear existing content
  60. wsSummary.Cells.Clear
  61.  
  62. ' Add headers and labels
  63. With wsSummary
  64. .Cells(1, 1).Value = "Prolific Summary"
  65. .Cells(3, 1).Value = "Study Status Breakdown"
  66. .Cells(4, 1).Value = "Approved Studies"
  67. .Cells(5, 1).Value = "Returned Studies"
  68. .Cells(6, 1).Value = "Awaiting Review Studies"
  69. .Cells(7, 1).Value = "Rejected Studies"
  70. .Cells(8, 1).Value = "Approval Rating"
  71.  
  72. .Cells(10, 1).Value = "Financial Summary"
  73. .Cells(11, 1).Value = "Total Reward (£)"
  74. .Cells(12, 1).Value = "Total Bonus (£)"
  75. .Cells(13, 1).Value = "Total Reward ($)"
  76. .Cells(14, 1).Value = "Total Bonus ($)"
  77. .Cells(15, 1).Value = "Total Returned Bonus (£)"
  78. .Cells(16, 1).Value = "Total Returned Bonus ($)"
  79.  
  80. .Cells(18, 1).Value = "Exchange Rate (GBP to USD) "
  81. .Cells(19, 1).Value = "Total GBP Converted to USD"
  82. .Cells(20, 1).Value = "Total Combined USD"
  83.  
  84. .Cells(22, 1).Value = "Time and Rate Analysis"
  85. .Cells(23, 1).Value = "Total Hours"
  86. .Cells(24, 1).Value = "Hourly Rate ($)"
  87.  
  88. ' Add exchange rate input cell with default value
  89. .Cells(18, 2).Value = 1.32042 ' Average exchange rate 2015 - 2024
  90. End With
  91.  
  92. ' Calculate status counts
  93. With wsData.Range("J2:J" & lastRow) ' Status column
  94. wsSummary.Cells(4, 2).Value = Application.CountIf(.Cells, "APPROVED")
  95. wsSummary.Cells(5, 2).Value = Application.CountIf(.Cells, "RETURNED")
  96. wsSummary.Cells(6, 2).Value = Application.CountIf(.Cells, "AWAITING REVIEW")
  97. wsSummary.Cells(7, 2).Value = Application.CountIf(.Cells, "REJECTED")
  98. End With
  99.  
  100. ' Calculate approval rating
  101. Dim approvedCount As Long, rejectedCount As Long
  102. approvedCount = wsSummary.Cells(4, 2).Value
  103. rejectedCount = wsSummary.Cells(7, 2).Value
  104. If (approvedCount + rejectedCount) > 0 Then
  105. wsSummary.Cells(8, 2).Value = approvedCount / (approvedCount + rejectedCount)
  106. wsSummary.Cells(8, 2).NumberFormat = "0.00%"
  107. End If
  108.  
  109. ' Calculate financial totals
  110. With Application.WorksheetFunction
  111. ' Approved studies totals
  112. wsSummary.Cells(11, 2).Value = .SumIfs(wsData.Range("B2:B" & lastRow), _
  113. wsData.Range("J2:J" & lastRow), "APPROVED") ' Reward GBP
  114. wsSummary.Cells(12, 2).Value = .SumIfs(wsData.Range("C2:C" & lastRow), _
  115. wsData.Range("J2:J" & lastRow), "APPROVED") ' Bonus GBP
  116. wsSummary.Cells(13, 2).Value = .SumIfs(wsData.Range("D2:D" & lastRow), _
  117. wsData.Range("J2:J" & lastRow), "APPROVED") ' Reward USD
  118. wsSummary.Cells(14, 2).Value = .SumIfs(wsData.Range("E2:E" & lastRow), _
  119. wsData.Range("J2:J" & lastRow), "APPROVED") ' Bonus USD
  120.  
  121. ' Returned bonus totals
  122. wsSummary.Cells(15, 2).Value = .SumIfs(wsData.Range("C2:C" & lastRow), _
  123. wsData.Range("J2:J" & lastRow), "RETURNED") ' Returned Bonus GBP
  124. wsSummary.Cells(16, 2).Value = .SumIfs(wsData.Range("E2:E" & lastRow), _
  125. wsData.Range("J2:J" & lastRow), "RETURNED") ' Returned Bonus USD
  126. End With
  127.  
  128. ' Calculate GBP to USD conversion
  129. Dim totalGBP As Double
  130. totalGBP = wsSummary.Cells(11, 2).Value + wsSummary.Cells(12, 2).Value + wsSummary.Cells(15, 2).Value
  131. wsSummary.Cells(19, 2).Formula = "=(" & wsSummary.Cells(11, 2).Address & "+" & _
  132. wsSummary.Cells(12, 2).Address & "+" & _
  133. wsSummary.Cells(15, 2).Address & ")*" & _
  134. wsSummary.Cells(18, 2).Address
  135.  
  136. ' Calculate total combined USD
  137. wsSummary.Cells(20, 2).Value = wsSummary.Cells(13, 2).Value + wsSummary.Cells(14, 2).Value + _
  138. wsSummary.Cells(16, 2).Value + wsSummary.Cells(19, 2).Value
  139.  
  140. ' Calculate total duration for approved and valid returned studies
  141. Dim totalSeconds As Double
  142. totalSeconds = 0
  143.  
  144. Dim i As Long
  145. For i = 2 To lastRow
  146. If (wsData.Cells(i, "J").Value = "APPROVED" Or wsData.Cells(i, "J").Value = "RETURNED") And _
  147. Not IsEmpty(wsData.Cells(i, "F").Value) And Not IsEmpty(wsData.Cells(i, "G").Value) Then
  148. ' Convert duration to seconds
  149. totalSeconds = totalSeconds + (wsData.Cells(i, "H").Value * 86400) ' 86400 seconds in a day
  150. End If
  151. Next i
  152.  
  153. ' Convert total seconds to duration format
  154. wsSummary.Cells(23, 2).Value = totalSeconds / 86400 ' Convert back to Excel time format
  155.  
  156. ' Calculate hourly rate
  157. If totalSeconds > 0 Then
  158. wsSummary.Cells(24, 2).Value = wsSummary.Cells(20, 2).Value / (totalSeconds / 3600) ' Convert seconds to hours
  159. End If
  160.  
  161. ' Format numbers
  162. With wsSummary
  163. .Range("B11:B12,B15").NumberFormat = "£#,##0.00" ' GBP amounts
  164. .Range("B13:B14,B16,B19:B20,B24").NumberFormat = "[$$-en-US]#,##0.00" ' USD amounts
  165. .Range("B23").NumberFormat = "[h]:mm:ss"
  166. .Range("B18").NumberFormat = "0.000000"
  167. End With
  168.  
  169. ' Add styling to the summary sheet
  170. With wsSummary
  171. ' Set dark background and remove gridlines
  172. .Cells.Interior.Color = RGB(32, 32, 32)
  173. ActiveWindow.DisplayGridlines = False
  174. .Cells.Font.Color = RGB(255, 255, 255)
  175.  
  176. ' AutoFit columns
  177. .Columns("A").ColumnWidth = 30
  178. .Columns("B").AutoFit
  179.  
  180. ' Main title formatting
  181. With .Range("A1:B1")
  182. .Merge
  183. .Font.Size = 14
  184. .Font.Bold = True
  185. .HorizontalAlignment = xlCenter
  186. .Interior.Color = RGB(64, 64, 64)
  187. End With
  188.  
  189. ' Section headers formatting
  190. With .Range("A3,A10,A22")
  191. .Font.Bold = True
  192. .Font.Size = 12
  193. .Interior.Color = RGB(64, 64, 64)
  194. End With
  195.  
  196. ' Add borders to the data ranges
  197. With .Range("A4:B8,A11:B16,A18:B20,A23:B24")
  198. .Borders(xlEdgeLeft).LineStyle = xlContinuous
  199. .Borders(xlEdgeLeft).Color = RGB(128, 128, 128)
  200. .Borders(xlEdgeRight).LineStyle = xlContinuous
  201. .Borders(xlEdgeRight).Color = RGB(128, 128, 128)
  202. .Borders(xlEdgeTop).LineStyle = xlContinuous
  203. .Borders(xlEdgeTop).Color = RGB(128, 128, 128)
  204. .Borders(xlEdgeBottom).LineStyle = xlContinuous
  205. .Borders(xlEdgeBottom).Color = RGB(128, 128, 128)
  206. .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  207. .Borders(xlInsideHorizontal).Color = RGB(128, 128, 128)
  208. End With
  209.  
  210. ' Alternate row coloring for better readability
  211. With .Range("A4:B8")
  212. .Interior.Color = RGB(45, 45, 45)
  213. End With
  214. With .Range("A11:B16")
  215. .Interior.Color = RGB(45, 45, 45)
  216. End With
  217. With .Range("A23:B24")
  218. .Interior.Color = RGB(45, 45, 45)
  219. End With
  220.  
  221. ' Exchange rate cell special formatting
  222. With .Range("B18")
  223. .Interior.Color = RGB(0, 100, 0) ' Darker green
  224. .Borders.LineStyle = xlContinuous
  225. .Borders.Color = RGB(128, 128, 128)
  226. End With
  227.  
  228. ' Indent labels slightly
  229. .Range("A4:A8,A11:A16,A18:A20,A23:A24").IndentLevel = 1
  230.  
  231. ' Bold totals and important figures
  232. .Range("B8,B20,B24").Font.Bold = True
  233.  
  234. ' Add a thin border around the entire summary
  235. With .Range(.Cells(1, 1), .Cells(24, 2))
  236. .BorderAround Weight:=xlThin, Color:=RGB(128, 128, 128)
  237. End With
  238.  
  239. ' Select A1 and zoom to 100%
  240. .Range("A1").Select
  241. ActiveWindow.Zoom = 100
  242. End With
  243.  
  244. ' Create trend line chart
  245. Dim chtTrends As Chart
  246. Dim tempWs As Worksheet
  247.  
  248. ' Create temporary worksheet for data
  249. On Error Resume Next
  250. ThisWorkbook.Sheets("TempData").Delete
  251. Set tempWs = ThisWorkbook.Sheets.Add
  252. tempWs.Name = "TempData"
  253. On Error GoTo 0
  254.  
  255. ' Create data table for Approved studies by year and month
  256. With tempWs
  257. ' Headers
  258. .Cells(1, 1).Value = "Year"
  259. .Cells(1, 2).Value = "Month"
  260. .Cells(1, 3).Value = "Number of Approved Studies"
  261. .Cells(1, 4).Value = "X-Axis Label"
  262. .Cells(1, 5).Value = "MonthNum"
  263. .Cells(1, 6).Value = "Number of Returned Studies"
  264. .Cells(1, 7).Value = "Number of Rejected Studies"
  265.  
  266. Dim chartRow As Long
  267. chartRow = 2
  268.  
  269. Dim yearMonth As Object
  270. Set yearMonth = CreateObject("Scripting.Dictionary")
  271.  
  272. Dim rowNum As Long
  273. For rowNum = 2 To lastRow
  274. Dim monthNum As Long
  275. monthNum = wsData.Cells(rowNum, "M").Value
  276.  
  277. ' Convert month number to name
  278. Dim monthName As String
  279. Select Case monthNum
  280. Case 1: monthName = "Jan"
  281. Case 2: monthName = "Feb"
  282. Case 3: monthName = "Mar"
  283. Case 4: monthName = "Apr"
  284. Case 5: monthName = "May"
  285. Case 6: monthName = "Jun"
  286. Case 7: monthName = "Jul"
  287. Case 8: monthName = "Aug"
  288. Case 9: monthName = "Sep"
  289. Case 10: monthName = "Oct"
  290. Case 11: monthName = "Nov"
  291. Case 12: monthName = "Dec"
  292. End Select
  293.  
  294. Dim key As String
  295. key = wsData.Cells(rowNum, "L").Value & "-" & Format(monthNum, "00")
  296.  
  297. If Not yearMonth.Exists(key) Then
  298. yearMonth.Add key, 1
  299.  
  300. ' Write data immediately
  301. .Cells(chartRow, 1).Value = wsData.Cells(rowNum, "L").Value ' Year
  302. .Cells(chartRow, 2).Value = monthName ' Month name
  303. .Cells(chartRow, 3).Value = 0 ' Approved count
  304. .Cells(chartRow, 6).Value = 0 ' Returned count
  305. .Cells(chartRow, 7).Value = 0 ' Rejected count
  306.  
  307. ' Increment appropriate counter
  308. Select Case wsData.Cells(rowNum, "J").Value
  309. Case "APPROVED": .Cells(chartRow, 3).Value = 1
  310. Case "RETURNED": .Cells(chartRow, 6).Value = 1
  311. Case "REJECTED": .Cells(chartRow, 7).Value = 1
  312. End Select
  313.  
  314. chartRow = chartRow + 1
  315. Else
  316. ' Find the row with matching year and month and update count
  317. Dim findRow As Long
  318. For findRow = 2 To chartRow - 1
  319. If .Cells(findRow, 1).Value = wsData.Cells(rowNum, "L").Value And _
  320. .Cells(findRow, 2).Value = monthName Then
  321. ' Increment appropriate counter
  322. Select Case wsData.Cells(rowNum, "J").Value
  323. Case "APPROVED": .Cells(findRow, 3).Value = .Cells(findRow, 3).Value + 1
  324. Case "RETURNED": .Cells(findRow, 6).Value = .Cells(findRow, 6).Value + 1
  325. Case "REJECTED": .Cells(findRow, 7).Value = .Cells(findRow, 7).Value + 1
  326. End Select
  327. Exit For
  328. End If
  329. Next findRow
  330. End If
  331. Next rowNum
  332.  
  333. ' Add helper column for month numbers
  334. .Cells(1, 5).Value = "MonthNum"
  335.  
  336. ' Fill in month numbers
  337. For i = 2 To chartRow - 1
  338. Select Case .Cells(i, 2).Value
  339. Case "Jan": .Cells(i, 5).Value = 1
  340. Case "Feb": .Cells(i, 5).Value = 2
  341. Case "Mar": .Cells(i, 5).Value = 3
  342. Case "Apr": .Cells(i, 5).Value = 4
  343. Case "May": .Cells(i, 5).Value = 5
  344. Case "Jun": .Cells(i, 5).Value = 6
  345. Case "Jul": .Cells(i, 5).Value = 7
  346. Case "Aug": .Cells(i, 5).Value = 8
  347. Case "Sep": .Cells(i, 5).Value = 9
  348. Case "Oct": .Cells(i, 5).Value = 10
  349. Case "Nov": .Cells(i, 5).Value = 11
  350. Case "Dec": .Cells(i, 5).Value = 12
  351. End Select
  352. Next i
  353.  
  354. ' Sort the data by year and month number
  355. .Range("A2:G" & chartRow - 1).Sort _
  356. Key1:=.Range("A2"), Order1:=xlAscending, _
  357. Key2:=.Range("E2"), Order2:=xlAscending, _
  358. Header:=xlNo
  359.  
  360. ' Create formatted X-axis labels
  361. Dim prevYear As String
  362. Dim currYear As String
  363.  
  364. For i = 2 To chartRow - 1
  365. currYear = .Cells(i, 1).Value
  366.  
  367. If currYear <> prevYear Then
  368. ' If it's a new year, include the year
  369. .Cells(i, 4).Value = currYear & " - " & .Cells(i, 2).Value
  370. Else
  371. ' If it's the same year, just show month
  372. .Cells(i, 4).Value = .Cells(i, 2).Value
  373. End If
  374.  
  375. prevYear = currYear
  376. Next i
  377. End With
  378.  
  379. ' Create the chart
  380. Set chtTrends = wsSummary.Shapes.AddChart2(227, xlLine).Chart
  381.  
  382. ' First, modify the data in tempWs to replace zeros with empty cells
  383. For i = 2 To chartRow - 1
  384. If tempWs.Cells(i, 6).Value = 0 Then tempWs.Cells(i, 6).ClearContents
  385. If tempWs.Cells(i, 7).Value = 0 Then tempWs.Cells(i, 7).ClearContents
  386. Next i
  387.  
  388. With chtTrends
  389. ' Clear any existing series
  390. Do While .SeriesCollection.count > 0
  391. .SeriesCollection(1).Delete
  392. Loop
  393.  
  394. ' Format chart area
  395. .ChartArea.Format.Fill.ForeColor.RGB = RGB(32, 32, 32)
  396. .PlotArea.Format.Fill.ForeColor.RGB = RGB(32, 32, 32)
  397.  
  398. ' Add Approved Studies series
  399. With .SeriesCollection.NewSeries
  400. .XValues = tempWs.Range("D2:D" & chartRow - 1)
  401. .values = tempWs.Range("C2:C" & chartRow - 1)
  402. .Format.Line.ForeColor.RGB = RGB(0, 255, 0) ' Green
  403. .Format.Line.Weight = 1.5
  404. .MarkerStyle = xlMarkerStyleCircle
  405. .MarkerSize = 4
  406. .Name = "Approved Studies"
  407.  
  408. .HasDataLabels = True
  409. With .DataLabels
  410. .ShowSeriesName = False
  411. .ShowValue = True
  412. .Position = xlLabelPositionAbove
  413. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  414. End With
  415. End With
  416.  
  417. ' Add Returned Studies series
  418. With .SeriesCollection.NewSeries
  419. .XValues = tempWs.Range("D2:D" & chartRow - 1)
  420. .values = tempWs.Range("F2:F" & chartRow - 1)
  421. .Format.Line.ForeColor.RGB = RGB(255, 165, 0) ' Orange
  422. .Format.Line.Weight = 1.5
  423. .MarkerStyle = xlMarkerStyleCircle
  424. .MarkerSize = 4
  425. .Name = "Returned Studies"
  426.  
  427. .HasDataLabels = True
  428. With .DataLabels
  429. .ShowSeriesName = False
  430. .ShowValue = True
  431. .Position = xlLabelPositionAbove
  432. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  433. End With
  434. End With
  435.  
  436. ' Add Rejected Studies series
  437. With .SeriesCollection.NewSeries
  438. .XValues = tempWs.Range("D2:D" & chartRow - 1)
  439. .values = tempWs.Range("G2:G" & chartRow - 1)
  440. .Format.Line.ForeColor.RGB = RGB(255, 0, 0) ' Red
  441. .Format.Line.Weight = 1.5
  442. .MarkerStyle = xlMarkerStyleCircle
  443. .MarkerSize = 3
  444. .Name = "Rejected Studies"
  445.  
  446. .HasDataLabels = True
  447. With .DataLabels
  448. .ShowSeriesName = False
  449. .ShowValue = True
  450. .Position = xlLabelPositionAbove
  451. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  452. End With
  453. End With
  454.  
  455. ' Add legend
  456. .HasLegend = True
  457. With .Legend
  458. .Position = xlBottom
  459. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  460. End With
  461.  
  462. ' Format Y axis
  463. With .Axes(xlValue)
  464. .HasTitle = True
  465. With .AxisTitle
  466. .Text = "Number of Studies"
  467. .Orientation = 90
  468. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  469. End With
  470. .TickLabels.Font.Color = RGB(255, 255, 255)
  471. .Format.Line.ForeColor.RGB = RGB(255, 255, 255)
  472. .MajorGridlines.Format.Line.ForeColor.RGB = RGB(64, 64, 64)
  473. .MinimumScale = 0
  474. End With
  475.  
  476. ' Format X axis
  477. With .Axes(xlCategory)
  478. .TickLabels.Font.Color = RGB(255, 255, 255)
  479. .Format.Line.ForeColor.RGB = RGB(255, 255, 255)
  480. .TickLabelSpacing = 1
  481. .TickLabels.Orientation = 90
  482. End With
  483.  
  484. ' Add title
  485. .HasTitle = True
  486. With .ChartTitle
  487. .Text = "Number of Studies a Month"
  488. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  489. End With
  490.  
  491. ' Position the chart
  492. With .Parent
  493. .Left = wsSummary.Range("D2").Left
  494. .Top = wsSummary.Range("D2").Top
  495. .Width = 800
  496. .Height = 400
  497. End With
  498. End With
  499.  
  500. ' Create pivot tables on a new sheet
  501. Application.DisplayAlerts = False
  502.  
  503. ' Create new Pivot sheet
  504. Dim wsPivot As Worksheet
  505. On Error Resume Next
  506. ThisWorkbook.Sheets("Pivot_Analysis").Delete
  507. Set wsPivot = ThisWorkbook.Sheets.Add(After:=wsSummary)
  508. wsPivot.Name = "Pivot_Analysis"
  509. wsPivot.Parent.Windows(1).DisplayGridlines = False
  510. On Error GoTo 0
  511.  
  512. ' Create pivot tables on the new sheet
  513. CreateApprovedPivotTable wsData, wsPivot
  514. CreateReturnedPivotTable wsData, wsPivot
  515. Application.DisplayAlerts = True
  516.  
  517. ' Create bar chart after pivot tables exist
  518. CreateBarChart tempWs, wsSummary, chartRow
  519. End Sub
  520.  
  521. Public Sub CreateApprovedPivotTable(wsData As Worksheet, wsPivot As Worksheet)
  522. Dim pvtCache As PivotCache
  523. Dim pvt As PivotTable
  524. Dim lastRow As Long
  525.  
  526. ' Delete existing pivot table if it exists
  527. On Error Resume Next
  528. wsPivot.PivotTables("ApprovedPivotTable").TableRange2.Clear
  529. wsPivot.PivotTables("ApprovedPivotTable").Delete
  530. On Error GoTo 0
  531.  
  532. ' Create pivot cache from data
  533. lastRow = wsData.Cells(wsData.Rows.count, "A").End(xlUp).row
  534. Set pvtCache = ThisWorkbook.PivotCaches.Create( _
  535. SourceType:=xlDatabase, _
  536. SourceData:=wsData.Range("A1:M" & lastRow), _
  537. Version:=xlPivotTableVersion15)
  538.  
  539. ' Create Approved Studies pivot table starting at A4
  540. Set pvt = pvtCache.CreatePivotTable( _
  541. TableDestination:=wsPivot.Range("A4"), _
  542. TableName:="ApprovedPivotTable", _
  543. DefaultVersion:=xlPivotTableVersion15)
  544.  
  545. ' Change Row Labels caption to Year
  546. On Error Resume Next
  547. pvt.RowAxisLayout xlTabularRow
  548. pvt.PivotFields("Row Labels").Name = "Year"
  549. On Error GoTo 0
  550.  
  551. ' Add title above pivot table after creation
  552. With wsPivot.Range("A3")
  553. .Value = "Approved Studies Breakdown Analysis"
  554. .Font.Bold = True
  555. .Font.Size = 12
  556. End With
  557.  
  558. ' Configure pivot table
  559. With pvt
  560. ' Add Year field to rows
  561. .PivotFields("Year").Orientation = xlRowField
  562. .PivotFields("Year").Position = 1
  563.  
  564. ' Add Month field to rows and format
  565. With .PivotFields("Month")
  566. .Orientation = xlRowField
  567. .Position = 2
  568.  
  569. ' Create month names array
  570. Dim monthNames(1 To 12) As String
  571. monthNames(1) = "January"
  572. monthNames(2) = "February"
  573. monthNames(3) = "March"
  574. monthNames(4) = "April"
  575. monthNames(5) = "May"
  576. monthNames(6) = "June"
  577. monthNames(7) = "July"
  578. monthNames(8) = "August"
  579. monthNames(9) = "September"
  580. monthNames(10) = "October"
  581. monthNames(11) = "November"
  582. monthNames(12) = "December"
  583.  
  584. ' Apply month names to pivot items
  585. Dim i As Long
  586. For i = 1 To 12
  587. On Error Resume Next
  588. .PivotItems(CStr(i)).Caption = monthNames(i)
  589. On Error GoTo 0
  590. Next i
  591.  
  592. ' Group by quarters
  593. On Error Resume Next
  594. .Group Start:=1, End:=12, By:=3
  595. On Error GoTo 0
  596. End With
  597.  
  598. ' Add value fields
  599. With .AddDataField(.PivotFields("Reward (£)"), "Total Reward (£)", xlSum)
  600. .NumberFormat = "£#,##0.00"
  601. End With
  602.  
  603. With .AddDataField(.PivotFields("Reward ($)"), "Total Reward ($)", xlSum)
  604. .NumberFormat = "[$$-en-US]#,##0.00"
  605. End With
  606.  
  607. With .AddDataField(.PivotFields("Bonus (£)"), "Total Bonus (£)", xlSum)
  608. .NumberFormat = "£#,##0.00"
  609. End With
  610.  
  611. With .AddDataField(.PivotFields("Bonus ($)"), "Total Bonus ($)", xlSum)
  612. .NumberFormat = "[$$-en-US]#,##0.00"
  613. End With
  614.  
  615. With .AddDataField(.PivotFields("Duration"), "Total Duration", xlSum)
  616. .NumberFormat = "[h]:mm:ss"
  617. End With
  618.  
  619. ' Filter for APPROVED studies only
  620. On Error Resume Next
  621. With .PivotFields("Status")
  622. .Orientation = xlPageField
  623. .CurrentPage = "APPROVED"
  624. .EnableMultiplePageItems = False
  625. End With
  626. On Error GoTo 0
  627.  
  628. ' Format pivot table
  629. .ShowTableStyleRowStripes = True
  630. .TableStyle2 = "PivotStyleMedium15"
  631.  
  632. ' Collapse all field items
  633. .PivotFields("Year").ShowDetail = False
  634. End With
  635. End Sub
  636.  
  637. Public Sub CreateReturnedPivotTable(wsData As Worksheet, wsPivot As Worksheet)
  638. Dim pvtCache As PivotCache
  639. Dim pvt As PivotTable
  640. Dim lastRow As Long
  641.  
  642. ' Delete existing pivot table if it exists
  643. On Error Resume Next
  644. wsPivot.PivotTables("ReturnedPivotTable").TableRange2.Clear
  645. wsPivot.PivotTables("ReturnedPivotTable").Delete
  646. On Error GoTo 0
  647.  
  648. ' Create pivot cache from data
  649. lastRow = wsData.Cells(wsData.Rows.count, "A").End(xlUp).row
  650. Set pvtCache = ThisWorkbook.PivotCaches.Create( _
  651. SourceType:=xlDatabase, _
  652. SourceData:=wsData.Range("A1:M" & lastRow), _
  653. Version:=xlPivotTableVersion15)
  654.  
  655. ' Create Returned Studies pivot table starting at J4
  656. Set pvt = pvtCache.CreatePivotTable( _
  657. TableDestination:=wsPivot.Range("J4"), _
  658. TableName:="ReturnedPivotTable", _
  659. DefaultVersion:=xlPivotTableVersion15)
  660.  
  661. ' Change Row Labels caption to Year
  662. On Error Resume Next
  663. pvt.RowAxisLayout xlTabularRow
  664. pvt.PivotFields("Row Labels").Name = "Year"
  665. On Error GoTo 0
  666.  
  667. ' Add title above pivot table after creation
  668. With wsPivot.Range("J3")
  669. .Value = "Returned Studies Breakdown Analysis"
  670. .Font.Bold = True
  671. .Font.Size = 12
  672. End With
  673.  
  674. ' Configure pivot table
  675. With pvt
  676. ' Add Year field to rows
  677. .PivotFields("Year").Orientation = xlRowField
  678. .PivotFields("Year").Position = 1
  679.  
  680. ' Add Month field to rows and format
  681. With .PivotFields("Month")
  682. .Orientation = xlRowField
  683. .Position = 2
  684.  
  685. ' Create month names array
  686. Dim monthNames(1 To 12) As String
  687. monthNames(1) = "January"
  688. monthNames(2) = "February"
  689. monthNames(3) = "March"
  690. monthNames(4) = "April"
  691. monthNames(5) = "May"
  692. monthNames(6) = "June"
  693. monthNames(7) = "July"
  694. monthNames(8) = "August"
  695. monthNames(9) = "September"
  696. monthNames(10) = "October"
  697. monthNames(11) = "November"
  698. monthNames(12) = "December"
  699.  
  700. ' Apply month names to pivot items
  701. Dim i As Long
  702. For i = 1 To 12
  703. On Error Resume Next
  704. .PivotItems(CStr(i)).Caption = monthNames(i)
  705. On Error GoTo 0
  706. Next i
  707.  
  708. ' Group by quarters
  709. On Error Resume Next
  710. .Group Start:=1, End:=12, By:=3
  711. On Error GoTo 0
  712. End With
  713.  
  714. ' Add only Bonus fields
  715. With .AddDataField(.PivotFields("Bonus (£)"), "Total Bonus (£)", xlSum)
  716. .NumberFormat = "£#,##0.00"
  717. End With
  718.  
  719. With .AddDataField(.PivotFields("Bonus ($)"), "Total Bonus ($)", xlSum)
  720. .NumberFormat = "[$$-en-US]#,##0.00"
  721. End With
  722.  
  723. With .AddDataField(.PivotFields("Duration"), "Total Duration", xlSum)
  724. .NumberFormat = "[h]:mm:ss"
  725. End With
  726.  
  727. ' Filter for RETURNED studies only
  728. On Error Resume Next
  729. With .PivotFields("Status")
  730. .Orientation = xlPageField
  731. .CurrentPage = "RETURNED"
  732. .EnableMultiplePageItems = False
  733. End With
  734. On Error GoTo 0
  735.  
  736. ' Format pivot table
  737. .ShowTableStyleRowStripes = True
  738. .TableStyle2 = "PivotStyleMedium15"
  739.  
  740. ' Collapse all field items
  741. .PivotFields("Year").ShowDetail = False
  742. End With
  743. End Sub
  744.  
  745. Private Sub CreateBarChart(tempWs As Worksheet, wsSummary As Worksheet, chartRow As Long)
  746. Dim wsData As Worksheet
  747. Set wsData = ThisWorkbook.Sheets("Processed_Data")
  748.  
  749. ' Get last row
  750. Dim lastRow As Long
  751. lastRow = wsData.Cells(wsData.Rows.count, "A").End(xlUp).row
  752.  
  753. ' Create chart first
  754. Dim chtBars As Chart
  755. Set chtBars = wsSummary.Shapes.AddChart2(227, xlColumnStacked).Chart
  756.  
  757. ' Create dictionary for our data
  758. Dim monthDict As Object
  759. Set monthDict = CreateObject("Scripting.Dictionary")
  760.  
  761. ' First pass - collect data
  762. Dim i As Long
  763. For i = 2 To lastRow
  764. If wsData.Cells(i, "J").Value = "APPROVED" Or _
  765. (wsData.Cells(i, "J").Value = "RETURNED" And _
  766. Not IsEmpty(wsData.Cells(i, "F").Value) And _
  767. Not IsEmpty(wsData.Cells(i, "G").Value)) Then
  768.  
  769. Dim key As String
  770. key = Format(wsData.Cells(i, "L").Value, "0000") & Format(wsData.Cells(i, "M").Value, "00")
  771.  
  772. If Not monthDict.Exists(key) Then
  773. Dim monthLabel As String
  774. monthLabel = Format(DateSerial(wsData.Cells(i, "L").Value, wsData.Cells(i, "M").Value, 1), "mmm")
  775. monthDict.Add key, Array(monthLabel, 0, 0, 0, 0)
  776. End If
  777.  
  778. Dim values As Variant
  779. values = monthDict(key)
  780.  
  781. If wsData.Cells(i, "J").Value = "APPROVED" Then
  782. values(1) = values(1) + wsData.Cells(i, "B").Value ' Reward GBP
  783. values(2) = values(2) + wsData.Cells(i, "C").Value ' Bonus GBP
  784. values(3) = values(3) + wsData.Cells(i, "D").Value ' Reward USD
  785. values(4) = values(4) + wsData.Cells(i, "E").Value ' Bonus USD
  786. Else ' RETURNED
  787. values(2) = values(2) + wsData.Cells(i, "C").Value ' Bonus GBP
  788. values(4) = values(4) + wsData.Cells(i, "E").Value ' Bonus USD
  789. End If
  790.  
  791. monthDict(key) = values
  792. End If
  793. Next i
  794.  
  795. ' Convert dictionary to arrays
  796. Dim monthCount As Long
  797. monthCount = monthDict.count
  798.  
  799. Dim monthLabels() As String
  800. Dim rewardGBP() As Double
  801. Dim bonusGBP() As Double
  802. Dim rewardUSD() As Double
  803. Dim bonusUSD() As Double
  804.  
  805. ReDim monthLabels(0 To monthCount - 1)
  806. ReDim rewardGBP(0 To monthCount - 1)
  807. ReDim bonusGBP(0 To monthCount - 1)
  808. ReDim rewardUSD(0 To monthCount - 1)
  809. ReDim bonusUSD(0 To monthCount - 1)
  810.  
  811. ' Sort keys
  812. Dim keys() As String
  813. ReDim keys(0 To monthCount - 1)
  814. Dim k As Long
  815. k = 0
  816. Dim keyVar As Variant
  817. For Each keyVar In monthDict.keys
  818. keys(k) = keyVar
  819. k = k + 1
  820. Next keyVar
  821.  
  822. ' Sort the keys array
  823. Call QuickSort(keys, 0, monthCount - 1)
  824.  
  825. ' Fill arrays in sorted order
  826. Dim isFirstEntry As Boolean
  827. isFirstEntry = True
  828. Dim yearNum As Long, monthNum As Long
  829.  
  830. For i = 0 To monthCount - 1
  831. values = monthDict(keys(i))
  832.  
  833. ' Get year and month from the key
  834. yearNum = CLng(Left(keys(i), 4))
  835. monthNum = CLng(Right(keys(i), 2))
  836.  
  837. ' Format label
  838. If isFirstEntry Then
  839. ' First entry - always show year
  840. monthLabels(i) = yearNum & " - " & values(0)
  841. isFirstEntry = False
  842. ElseIf monthNum = 1 Then
  843. ' January - show year
  844. monthLabels(i) = yearNum & " - " & values(0)
  845. Else
  846. ' Other months - just show month
  847. monthLabels(i) = values(0)
  848. End If
  849.  
  850. rewardGBP(i) = values(1)
  851. bonusGBP(i) = values(2)
  852. rewardUSD(i) = values(3)
  853. bonusUSD(i) = values(4)
  854. Next i
  855.  
  856. ' Create the chart
  857. With chtBars
  858. .ChartType = xlColumnStacked
  859.  
  860. ' Clear any existing series
  861. Do While .SeriesCollection.count > 0
  862. .SeriesCollection(1).Delete
  863. Loop
  864.  
  865. ' Add series
  866. With .SeriesCollection.NewSeries
  867. .Name = "Total Reward (£)"
  868. .values = rewardGBP
  869. .XValues = monthLabels
  870. .Format.Fill.ForeColor.RGB = RGB(0, 176, 80) ' Dark Green
  871. End With
  872.  
  873. With .SeriesCollection.NewSeries
  874. .Name = "Total Bonus (£)"
  875. .values = bonusGBP
  876. .XValues = monthLabels
  877. .Format.Fill.ForeColor.RGB = RGB(146, 208, 80) ' Light Green
  878. End With
  879.  
  880. With .SeriesCollection.NewSeries
  881. .Name = "Total Reward ($)"
  882. .values = rewardUSD
  883. .XValues = monthLabels
  884. .Format.Fill.ForeColor.RGB = RGB(0, 112, 192) ' Dark Blue
  885. End With
  886.  
  887. With .SeriesCollection.NewSeries
  888. .Name = "Total Bonus ($)"
  889. .values = bonusUSD
  890. .XValues = monthLabels
  891. .Format.Fill.ForeColor.RGB = RGB(91, 155, 213) ' Light Blue
  892. End With
  893.  
  894. ' Format chart
  895. .ChartArea.Format.Fill.ForeColor.RGB = RGB(32, 32, 32)
  896. .PlotArea.Format.Fill.ForeColor.RGB = RGB(32, 32, 32)
  897.  
  898. ' Format axes
  899. With .Axes(xlValue)
  900. .HasTitle = True
  901. .AxisTitle.Text = "Amount"
  902. .AxisTitle.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  903. .TickLabels.Font.Color = RGB(255, 255, 255)
  904. .Format.Line.ForeColor.RGB = RGB(255, 255, 255)
  905. .TickLabels.NumberFormat = "#,##0.00" ' Removed £ symbol
  906. .MajorGridlines.Format.Line.ForeColor.RGB = RGB(64, 64, 64)
  907. End With
  908.  
  909. With .Axes(xlCategory)
  910. .TickLabels.Font.Color = RGB(255, 255, 255)
  911. .Format.Line.ForeColor.RGB = RGB(255, 255, 255)
  912. .TickLabelSpacing = 1 ' Show all labels
  913. .TickLabels.Orientation = 90 ' Vertical labels
  914. End With
  915.  
  916. ' Add title and legend
  917. .HasTitle = True
  918. .ChartTitle.Text = "Monthly Rewards and Bonuses"
  919. .ChartTitle.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  920.  
  921. .HasLegend = True
  922. .Legend.Position = xlBottom
  923. .Legend.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  924.  
  925. ' Position the chart
  926. With .Parent
  927. .Left = wsSummary.Range("D29").Left
  928. .Top = wsSummary.Range("D29").Top
  929. .Width = 800
  930. .Height = 400
  931. End With
  932. End With
  933. End Sub
  934.  
  935. ' Helper function for sorting
  936. Private Sub QuickSort(arr() As String, low As Long, high As Long)
  937. Dim pivot As String
  938. Dim tmp As String
  939. Dim i As Long
  940. Dim j As Long
  941.  
  942. If low < high Then
  943. pivot = arr((low + high) \ 2)
  944. i = low
  945. j = high
  946.  
  947. Do
  948. Do While arr(i) < pivot
  949. i = i + 1
  950. Loop
  951.  
  952. Do While arr(j) > pivot
  953. j = j - 1
  954. Loop
  955.  
  956. If i <= j Then
  957. tmp = arr(i)
  958. arr(i) = arr(j)
  959. arr(j) = tmp
  960. i = i + 1
  961. j = j - 1
  962. End If
  963. Loop Until i > j
  964.  
  965. If low < j Then QuickSort arr, low, j
  966. If i < high Then QuickSort arr, i, high
  967. End If
  968. End Sub
  969.  
  970. Private Sub TestHourlyRateCalculation()
  971. ' Prevent screen updating
  972. Application.ScreenUpdating = False
  973.  
  974. Dim wsData As Worksheet
  975. Dim wsSummary As Worksheet
  976.  
  977. ' Get the required worksheets
  978. Set wsData = ThisWorkbook.Sheets("Processed_Data")
  979. Set wsSummary = ThisWorkbook.Sheets("Summary")
  980.  
  981. ' Create temporary storage for our calculations
  982. Dim tempWs As Worksheet
  983.  
  984. ' Create/recreate temp worksheet
  985. On Error Resume Next
  986. ThisWorkbook.Sheets("TempHourlyRate").Delete
  987. Set tempWs = ThisWorkbook.Sheets.Add
  988. tempWs.Name = "TempHourlyRate"
  989. On Error GoTo 0
  990.  
  991. ' Setup headers with separate currency columns
  992. With tempWs
  993. .Cells(1, 1).Value = "Year"
  994. .Cells(1, 2).Value = "Month"
  995. .Cells(1, 3).Value = "Total Hours"
  996. .Cells(1, 4).Value = "Total GBP"
  997. .Cells(1, 5).Value = "Total USD"
  998. .Cells(1, 6).Value = "Hourly Rate"
  999. End With
  1000.  
  1001. ' Create dictionary to store monthly data
  1002. Dim monthData As Object
  1003. Set monthData = CreateObject("Scripting.Dictionary")
  1004.  
  1005. ' Get last row
  1006. Dim lastRow As Long
  1007. lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
  1008.  
  1009. ' Process each row
  1010. Dim i As Long
  1011. For i = 2 To lastRow
  1012. Dim hasValidTimes As Boolean
  1013. hasValidTimes = Not IsEmpty(wsData.Cells(i, "F").Value) And _
  1014. Not IsEmpty(wsData.Cells(i, "G").Value)
  1015.  
  1016. ' Calculate earnings and hours based on status
  1017. If wsData.Cells(i, "J").Value = "APPROVED" Or _
  1018. (wsData.Cells(i, "J").Value = "RETURNED" And hasValidTimes) Then
  1019.  
  1020. ' Create key for year-month
  1021. Dim key As String
  1022. key = Format(wsData.Cells(i, "L").Value, "0000") & Format(wsData.Cells(i, "M").Value, "00")
  1023.  
  1024. ' Calculate earnings for this entry
  1025. Dim entryGBP As Double, entryUSD As Double
  1026. If wsData.Cells(i, "J").Value = "APPROVED" Then
  1027. ' For Approved: Include all rewards and bonuses
  1028. entryGBP = wsData.Cells(i, "B").Value + wsData.Cells(i, "C").Value
  1029. entryUSD = wsData.Cells(i, "D").Value + wsData.Cells(i, "E").Value
  1030. Else ' RETURNED with valid times
  1031. ' For Returned: Only include bonuses
  1032. entryGBP = wsData.Cells(i, "C").Value
  1033. entryUSD = wsData.Cells(i, "E").Value
  1034. End If
  1035.  
  1036. ' Only add hours if we have valid times
  1037. Dim entryHours As Double
  1038. If hasValidTimes Then
  1039. entryHours = wsData.Cells(i, "H").Value * 24 ' Convert to hours
  1040. End If
  1041.  
  1042. ' Add or update dictionary entry
  1043. If Not monthData.Exists(key) Then
  1044. monthData.Add key, Array(wsData.Cells(i, "L").Value, _
  1045. wsData.Cells(i, "M").Value, _
  1046. entryHours, _
  1047. entryGBP, _
  1048. entryUSD)
  1049. Else
  1050. Dim existingData As Variant
  1051. existingData = monthData(key)
  1052. existingData(2) = existingData(2) + entryHours
  1053. existingData(3) = existingData(3) + entryGBP
  1054. existingData(4) = existingData(4) + entryUSD
  1055. monthData(key) = existingData
  1056. End If
  1057. End If
  1058. Next i
  1059.  
  1060. ' Write sorted data
  1061. Dim row As Long
  1062. row = 2
  1063.  
  1064. ' Create and populate keys array
  1065. Dim keys() As String
  1066. ReDim keys(0 To monthData.Count - 1)
  1067. Dim k As Long
  1068. k = 0
  1069. Dim keyVar As Variant
  1070. For Each keyVar In monthData.keys
  1071. keys(k) = keyVar
  1072. k = k + 1
  1073. Next keyVar
  1074.  
  1075. ' Sort keys array
  1076. QuickSort keys, LBound(keys), UBound(keys)
  1077.  
  1078. ' Get exchange rate
  1079. Dim exchangeRate As Double
  1080. exchangeRate = wsSummary.Range("B18").Value
  1081.  
  1082. ' Write sorted data
  1083. For k = LBound(keys) To UBound(keys)
  1084. Dim data As Variant
  1085. data = monthData(keys(k))
  1086.  
  1087. With tempWs
  1088. .Cells(row, 1).Value = data(0) ' Year
  1089. .Cells(row, 2).Value = monthName(data(1), True) ' Month
  1090. .Cells(row, 3).Value = data(2) / 24 ' Convert hours back to Excel time format
  1091. .Cells(row, 4).Value = data(3) ' GBP
  1092. .Cells(row, 5).Value = data(4) ' USD
  1093.  
  1094. ' Calculate hourly rate including converted USD
  1095. If data(2) > 0 Then
  1096. .Cells(row, 6).Value = (data(3) + (data(4) * exchangeRate)) / data(2)
  1097. Else
  1098. .Cells(row, 6).Value = 0
  1099. End If
  1100.  
  1101. ' Format cells
  1102. .Cells(row, 3).NumberFormat = "[h]:mm:ss"
  1103. .Cells(row, 4).NumberFormat = "£#,##0.00"
  1104. .Cells(row, 5).NumberFormat = "[$$-en-US]#,##0.00"
  1105. .Cells(row, 6).NumberFormat = "£#,##0.00"
  1106. End With
  1107. row = row + 1
  1108. Next k
  1109.  
  1110. ' Autofit columns
  1111. tempWs.Columns("A:F").AutoFit
  1112.  
  1113. ' Hide sheet
  1114. tempWs.Visible = xlSheetVeryHidden
  1115. End Sub
  1116.  
  1117. Private Sub CreateHourlyRateChartOnSummary()
  1118. Dim tempWs As Worksheet
  1119. Dim wsSummary As Worksheet
  1120. Dim cht As Chart
  1121. Dim cboYear As Shape
  1122. Dim years As Collection
  1123. Dim yr As Variant
  1124.  
  1125. ' Get the required worksheets
  1126. Set tempWs = ThisWorkbook.Sheets("TempHourlyRate")
  1127. Set wsSummary = ThisWorkbook.Sheets("Summary")
  1128.  
  1129. ' Get years collection first
  1130. Set years = GetUniqueYears(tempWs)
  1131.  
  1132. ' Add combobox for year selection at W1
  1133. Set cboYear = wsSummary.Shapes.AddFormControl(xlDropDown, _
  1134. wsSummary.Range("W1").Left, _
  1135. wsSummary.Range("W1").Top, _
  1136. 80, 20)
  1137.  
  1138. ' Style the combobox and its surroundings
  1139. With cboYear
  1140. .OnAction = "YearSelected"
  1141.  
  1142. ' Add a label for the dropdown with dark background
  1143. With wsSummary.Range("V1")
  1144. .Value = "Select Year:"
  1145. .Font.Color = RGB(255, 255, 255)
  1146. .Font.Bold = True
  1147. .Interior.Color = RGB(32, 32, 32) ' Match dropdown background
  1148. .HorizontalAlignment = xlRight
  1149. End With
  1150.  
  1151. ' Add background cell styling for dropdown
  1152. With wsSummary.Range("W1")
  1153. .Interior.Color = RGB(64, 64, 64)
  1154. End With
  1155.  
  1156. ' Populate years
  1157. For Each yr In years
  1158. .ControlFormat.AddItem yr
  1159. Next yr
  1160. .ControlFormat.ListIndex = 1
  1161.  
  1162. ' Position carefully
  1163. .Left = wsSummary.Range("W1").Left + 1 ' Slight offset to align with cell
  1164. .Top = wsSummary.Range("W1").Top + 1
  1165. .Width = wsSummary.Range("W1").Width - 2
  1166. .Height = wsSummary.Range("W1").Height - 2
  1167. End With
  1168.  
  1169. ' Create the chart
  1170. Set cht = wsSummary.Shapes.AddChart2(227, xlColumnClustered).Chart
  1171.  
  1172. ' Store chart name for reference in change event
  1173. cht.Parent.Name = "HourlyRateChart"
  1174.  
  1175. ' Format chart
  1176. With cht
  1177. ' Position the chart
  1178. .Parent.Left = wsSummary.Range("U2").Left
  1179. .Parent.Top = wsSummary.Range("U2").Top
  1180. .Parent.Width = 900
  1181. .Parent.Height = 600
  1182.  
  1183. .ChartArea.Format.Fill.ForeColor.RGB = RGB(32, 32, 32)
  1184. .PlotArea.Format.Fill.ForeColor.RGB = RGB(32, 32, 32)
  1185.  
  1186. ' Clear any existing series first
  1187. Do While .SeriesCollection.count > 0
  1188. .SeriesCollection(1).Delete
  1189. Loop
  1190.  
  1191. ' Add series for hourly rate
  1192. With .SeriesCollection.NewSeries
  1193. .Name = "Hourly Rate"
  1194. .Format.Fill.ForeColor.RGB = RGB(0, 176, 80) ' Green
  1195.  
  1196. ' Add data labels
  1197. .HasDataLabels = True
  1198. With .DataLabels
  1199. .ShowValue = False
  1200. .Position = xlLabelPositionOutsideEnd
  1201. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  1202. .Format.TextFrame2.TextRange.Font.Size = 9
  1203. .Format.Fill.ForeColor.RGB = RGB(64, 64, 64)
  1204. .Format.Fill.Transparency = 0.7
  1205. End With
  1206. End With
  1207.  
  1208. ' Format axes
  1209. With .Axes(xlValue)
  1210. .HasTitle = True
  1211. .AxisTitle.Text = "Hourly Rate (£)"
  1212. .AxisTitle.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  1213. .TickLabels.Font.Color = RGB(255, 255, 255)
  1214. .Format.Line.ForeColor.RGB = RGB(255, 255, 255)
  1215. .TickLabels.NumberFormat = "£#,##0.00"
  1216. .MajorGridlines.Format.Line.ForeColor.RGB = RGB(64, 64, 64)
  1217. End With
  1218.  
  1219. With .Axes(xlCategory)
  1220. .TickLabels.Font.Color = RGB(255, 255, 255)
  1221. .Format.Line.ForeColor.RGB = RGB(255, 255, 255)
  1222. End With
  1223.  
  1224. ' Add title
  1225. .HasTitle = True
  1226. .ChartTitle.Text = "Monthly Hourly Rate Analysis"
  1227. .ChartTitle.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  1228. .ChartTitle.Format.TextFrame2.TextRange.Font.Size = 14
  1229.  
  1230. ' Remove legend completely
  1231. .HasLegend = False ' Changed from True to False
  1232. End With
  1233.  
  1234. ' Add initial data for first year in list
  1235. If years.count > 0 Then
  1236. UpdateChartData cht, tempWs, years(1)
  1237. End If
  1238. End Sub
  1239.  
  1240. Private Function GetUniqueYears(ws As Worksheet) As Collection
  1241. Dim dict As Object
  1242. Dim cell As Range
  1243. Dim lastRow As Long
  1244.  
  1245. Set dict = CreateObject("Scripting.Dictionary")
  1246. lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).row
  1247.  
  1248. ' Get unique years from column A
  1249. For Each cell In ws.Range("A2:A" & lastRow)
  1250. If Not dict.Exists(cell.Value) Then
  1251. dict.Add cell.Value, cell.Value
  1252. End If
  1253. Next cell
  1254.  
  1255. ' Convert to collection and sort
  1256. Set GetUniqueYears = New Collection
  1257. Dim yearArray() As Variant
  1258. yearArray = dict.Items
  1259.  
  1260. ' Sort years
  1261. Dim i As Long, j As Long, temp As Variant
  1262. For i = LBound(yearArray) To UBound(yearArray) - 1
  1263. For j = i + 1 To UBound(yearArray)
  1264. If yearArray(i) > yearArray(j) Then
  1265. temp = yearArray(i)
  1266. yearArray(i) = yearArray(j)
  1267. yearArray(j) = temp
  1268. End If
  1269. Next j
  1270. Next i
  1271.  
  1272. ' Add sorted years to collection
  1273. For i = LBound(yearArray) To UBound(yearArray)
  1274. GetUniqueYears.Add yearArray(i)
  1275. Next i
  1276. End Function
  1277.  
  1278. Private Sub UpdateChartData(cht As Chart, dataWs As Worksheet, selectedYear As Integer)
  1279. ' Filter data for selected year
  1280. Dim lastRow As Long
  1281. Dim monthValues() As String
  1282. Dim hourlyRates() As Double
  1283. Dim customLabels() As String
  1284. Dim count As Long
  1285. Dim i As Long
  1286.  
  1287. lastRow = dataWs.Cells(dataWs.Rows.count, "A").End(xlUp).row
  1288.  
  1289. ' Get exchange rate from Summary sheet
  1290. Dim exchangeRate As Double
  1291. exchangeRate = ThisWorkbook.Sheets("Summary").Range("B18").Value
  1292.  
  1293. ' First count matching rows
  1294. count = 0
  1295. For i = 2 To lastRow
  1296. If dataWs.Cells(i, "A").Value = selectedYear Then
  1297. count = count + 1
  1298. End If
  1299. Next i
  1300.  
  1301. ' Size arrays
  1302. ReDim monthValues(1 To count)
  1303. ReDim hourlyRates(1 To count)
  1304. ReDim customLabels(1 To count)
  1305.  
  1306. ' Fill arrays
  1307. count = 0
  1308. For i = 2 To lastRow
  1309. If dataWs.Cells(i, "A").Value = selectedYear Then
  1310. count = count + 1
  1311. monthValues(count) = dataWs.Cells(i, "B").Value
  1312.  
  1313. ' Convert hourly rate from GBP to USD
  1314. hourlyRates(count) = dataWs.Cells(i, "F").Value * exchangeRate
  1315.  
  1316. ' Create custom label text
  1317. Dim timeValue As Double
  1318. timeValue = dataWs.Cells(i, "C").Value * 24 ' Convert to hours
  1319.  
  1320. ' Convert earnings to USD
  1321. Dim earnedUSD As Double
  1322. earnedUSD = dataWs.Cells(i, "D").Value * exchangeRate
  1323.  
  1324. customLabels(count) = "Hours: " & Format(timeValue, "0") & ":" & _
  1325. Format(timeValue * 60 Mod 60, "00") & ":" & _
  1326. Format(timeValue * 3600 Mod 60, "00") & vbNewLine & _
  1327. "Earned: " & Format(earnedUSD, "$#,##0.00") & vbNewLine & _
  1328. "Rate: " & Format(hourlyRates(count), "$#,##0.00")
  1329. End If
  1330. Next i
  1331.  
  1332. ' Find maximum hourly rate for scaling
  1333. Dim maxRate As Double
  1334. maxRate = 0
  1335. For i = 1 To count
  1336. If hourlyRates(i) > maxRate Then maxRate = hourlyRates(i)
  1337. Next i
  1338.  
  1339. ' Round up to next whole number and add buffer
  1340. maxRate = Application.WorksheetFunction.Ceiling(maxRate + 2, 1)
  1341.  
  1342. ' Update chart data
  1343. With cht.SeriesCollection(1)
  1344. .values = hourlyRates
  1345. .XValues = monthValues
  1346.  
  1347. ' Update data labels
  1348. .HasDataLabels = False
  1349. .HasDataLabels = True
  1350.  
  1351. With .DataLabels
  1352. .Position = xlLabelPositionOutsideEnd
  1353. .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  1354. .Format.TextFrame2.TextRange.Font.Size = 9
  1355. .Format.Fill.ForeColor.RGB = RGB(64, 64, 64)
  1356. .Format.Fill.Transparency = 0.7
  1357. End With
  1358.  
  1359. ' Set individual label text
  1360. Dim j As Long
  1361. For j = 1 To count
  1362. .Points(j).DataLabel.Text = customLabels(j)
  1363. Next j
  1364. End With
  1365.  
  1366. ' Adjust the plot area and chart formatting
  1367. With cht
  1368. ' Increase overall chart height to accommodate labels
  1369. .Parent.Height = 600
  1370.  
  1371. ' Position plot area using relative coordinates
  1372. With .PlotArea
  1373. .Format.Fill.ForeColor.RGB = RGB(32, 32, 32)
  1374. ' Move the plot area down more
  1375. .Top = .Top + 100 ' Increased from 50 to 100 points
  1376. End With
  1377.  
  1378. ' Set the value axis scaling with different increments
  1379. With .Axes(xlValue)
  1380. .MinimumScale = 8 ' Adjusted minimum for USD
  1381.  
  1382. ' Adjust maximum scale based on the highest rate
  1383. If maxRate <= 26 Then ' First threshold
  1384. .MaximumScale = WorksheetFunction.Ceiling(maxRate + 2, 1)
  1385. .MajorUnit = 2 ' $2 increments up to $26
  1386. .MinorUnit = 1 ' $1 minor units
  1387. ElseIf maxRate <= 30 Then ' Second threshold
  1388. ' For rates between $26 and $30, use $5 increments
  1389. Dim adjustedMax As Double
  1390. adjustedMax = WorksheetFunction.Ceiling(maxRate, 5) ' Round to nearest $5
  1391. If adjustedMax = maxRate Then adjustedMax = adjustedMax + 5
  1392.  
  1393. .MaximumScale = adjustedMax
  1394. .MinimumScale = 0 ' Start from 0 for better scale visibility
  1395. .MajorUnit = 5 ' $5 increments
  1396. .MinorUnit = 1 ' $1 minor units
  1397. Else
  1398. ' For rates above $30, use $10 increments
  1399. adjustedMax = WorksheetFunction.Ceiling(maxRate, 10) ' Round to nearest $10
  1400. If adjustedMax = maxRate Then adjustedMax = adjustedMax + 10
  1401.  
  1402. .MaximumScale = adjustedMax
  1403. .MinimumScale = 0 ' Start from 0 for better scale visibility
  1404. .MajorUnit = 10 ' $10 increments
  1405. .MinorUnit = 2 ' $2 minor units
  1406. End If
  1407.  
  1408. ' Format axis
  1409. .HasTitle = True
  1410. .AxisTitle.Text = "Hourly Rate ($)"
  1411. .AxisTitle.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
  1412. .TickLabels.Font.Color = RGB(255, 255, 255)
  1413. .Format.Line.ForeColor.RGB = RGB(255, 255, 255)
  1414. .TickLabels.NumberFormat = "[$$-en-US]#,##0.00"
  1415. .MajorGridlines.Format.Line.ForeColor.RGB = RGB(64, 64, 64)
  1416. End With
  1417. End With
  1418. End Sub
  1419.  
  1420. Private Sub CreateYearlyRateAnalysis()
  1421. Dim wsSummary As Worksheet
  1422. Set wsSummary = ThisWorkbook.Sheets("Summary")
  1423.  
  1424. ' Find the last used row in column A
  1425. Dim lastRow As Long
  1426. lastRow = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row
  1427.  
  1428. ' Add Yearly Rate Analysis section
  1429. With wsSummary
  1430. ' Insert two blank rows for spacing
  1431. .Rows(lastRow + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  1432. .Rows(lastRow + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  1433.  
  1434. ' Start our section
  1435. .Cells(lastRow + 2, 1).Value = "Yearly Hourly Rate Analysis"
  1436. .Range("A" & lastRow + 2 & ":B" & lastRow + 2).Merge
  1437. .Range("A" & lastRow + 2).Font.Size = 12
  1438. .Range("A" & lastRow + 2).Font.Bold = True
  1439. .Range("A" & lastRow + 2).Interior.Color = RGB(64, 64, 64)
  1440. .Range("A" & lastRow + 2).HorizontalAlignment = xlCenter
  1441.  
  1442. ' Get data from TempHourlyRate sheet
  1443. Dim tempWs As Worksheet
  1444. Set tempWs = ThisWorkbook.Sheets("TempHourlyRate")
  1445.  
  1446. ' Get exchange rate
  1447. Dim exchangeRate As Double
  1448. exchangeRate = wsSummary.Range("B18").Value
  1449.  
  1450. ' Create dictionary to store yearly totals
  1451. Dim yearlyData As Object
  1452. Set yearlyData = CreateObject("Scripting.Dictionary")
  1453.  
  1454. ' Calculate yearly totals
  1455. Dim lastTempRow As Long
  1456. lastTempRow = tempWs.Cells(tempWs.Rows.Count, "A").End(xlUp).Row
  1457.  
  1458. Dim i As Long
  1459. For i = 2 To lastTempRow
  1460. If Not IsEmpty(tempWs.Cells(i, 3).Value) Then
  1461. Dim year As Long
  1462. year = tempWs.Cells(i, 1).Value
  1463.  
  1464. If Not yearlyData.Exists(year) Then
  1465. yearlyData.Add year, Array(0, 0, 0) ' hours, GBP, USD
  1466. End If
  1467.  
  1468. Dim data As Variant
  1469. data = yearlyData(year)
  1470. data(0) = data(0) + tempWs.Cells(i, 3).Value ' Hours
  1471. data(1) = data(1) + tempWs.Cells(i, 4).Value ' GBP
  1472. data(2) = data(2) + tempWs.Cells(i, 5).Value ' USD
  1473. yearlyData(year) = data
  1474. End If
  1475. Next i
  1476.  
  1477. ' Output yearly data
  1478. Dim row As Long
  1479. row = lastRow + 3
  1480.  
  1481. ' Sort and output years
  1482. Dim years() As Long
  1483. ReDim years(0 To yearlyData.Count - 1)
  1484. Dim k As Long
  1485. k = 0
  1486. Dim yearKey As Variant
  1487. For Each yearKey In yearlyData.keys
  1488. years(k) = yearKey
  1489. k = k + 1
  1490. Next yearKey
  1491.  
  1492. ' Sort years
  1493. Dim j As Long, temp As Long
  1494. For i = LBound(years) To UBound(years) - 1
  1495. For j = i + 1 To UBound(years)
  1496. If years(i) > years(j) Then
  1497. temp = years(i)
  1498. years(i) = years(j)
  1499. years(j) = temp
  1500. End If
  1501. Next j
  1502. Next i
  1503.  
  1504. ' Output sorted data
  1505. For i = LBound(years) To UBound(years)
  1506. data = yearlyData(years(i))
  1507.  
  1508. ' Convert hours from days to actual hours for calculation
  1509. Dim totalHours As Double
  1510. totalHours = data(0) * 24 ' Convert days to hours
  1511.  
  1512. ' Calculate total earnings (GBP converted to USD + existing USD)
  1513. Dim totalEarnings As Double
  1514. totalEarnings = (data(1) * exchangeRate) + data(2) ' Convert GBP to USD and add existing USD
  1515.  
  1516. .Cells(row, 1).Value = "Year " & years(i)
  1517. .Cells(row + 1, 1).Value = "Hours"
  1518. .Cells(row + 1, 2).Value = data(0)
  1519. .Cells(row + 1, 2).NumberFormat = "[h]:mm:ss"
  1520.  
  1521. .Cells(row + 2, 1).Value = "Earnings"
  1522. .Cells(row + 2, 2).Value = totalEarnings
  1523. .Cells(row + 2, 2).NumberFormat = "[$$-en-US]#,##0.00"
  1524.  
  1525. .Cells(row + 3, 1).Value = "Hourly Rate"
  1526. If totalHours > 0 Then
  1527. .Cells(row + 3, 2).Value = totalEarnings / totalHours
  1528. Else
  1529. .Cells(row + 3, 2).Value = 0
  1530. End If
  1531. .Cells(row + 3, 2).NumberFormat = "[$$-en-US]#,##0.00"
  1532.  
  1533. ' Format cells
  1534. .Range("A" & row & ":B" & row + 3).Interior.Color = RGB(45, 45, 45)
  1535. .Range("A" & row + 1 & ":A" & row + 3).IndentLevel = 1
  1536.  
  1537. ' Add borders
  1538. With .Range("A" & row & ":B" & row + 3)
  1539. .Borders(xlEdgeLeft).LineStyle = xlContinuous
  1540. .Borders(xlEdgeLeft).Color = RGB(128, 128, 128)
  1541. .Borders(xlEdgeRight).LineStyle = xlContinuous
  1542. .Borders(xlEdgeRight).Color = RGB(128, 128, 128)
  1543. .Borders(xlEdgeTop).LineStyle = xlContinuous
  1544. .Borders(xlEdgeTop).Color = RGB(128, 128, 128)
  1545. .Borders(xlEdgeBottom).LineStyle = xlContinuous
  1546. .Borders(xlEdgeBottom).Color = RGB(128, 128, 128)
  1547. .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  1548. .Borders(xlInsideHorizontal).Color = RGB(128, 128, 128)
  1549. End With
  1550.  
  1551. row = row + 5
  1552. Next i
  1553.  
  1554. ' Add border around entire section
  1555. With .Range("A" & (lastRow + 2) & ":B" & row - 1)
  1556. .BorderAround Weight:=xlThin, Color:=RGB(128, 128, 128)
  1557. End With
  1558.  
  1559. ' Insert a blank row after the section
  1560. .Rows(row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  1561. End With
  1562. End Sub
  1563.  
  1564. Public Sub YearSelected()
  1565. Dim ws As Worksheet
  1566. Dim cht As Chart
  1567. Dim cboYear As Shape
  1568.  
  1569. Set ws = ActiveSheet
  1570. Set cht = ws.Shapes("HourlyRateChart").Chart
  1571. Set cboYear = ws.Shapes.Range(Array(Application.Caller))(1)
  1572.  
  1573. ' Get selected year
  1574. Dim selectedYear As Integer
  1575. selectedYear = cboYear.ControlFormat.List(cboYear.ControlFormat.ListIndex)
  1576.  
  1577. ' Update chart with selected year
  1578. UpdateChartData cht, ThisWorkbook.Sheets("TempHourlyRate"), selectedYear
  1579. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!