Guinaba
Board Regular
- Joined
- Sep 19, 2018
- Messages
- 215
- Office Version
- 2016
- Platform
- Windows
Hello guys,
I am trying to convert the left table to the right table where the code is counting the numbers of yellow cells by Supplier and date. I managed to get close to that using the code below, but still not correct, because I am not sure how to add two item columns in the dictionary
I am trying to convert the left table to the right table where the code is counting the numbers of yellow cells by Supplier and date. I managed to get close to that using the code below, but still not correct, because I am not sure how to add two item columns in the dictionary
VBA Code:
Option Explicit
Sub GetTotals()
' Get worksheet
Dim wk As Worksheet
Set wk = ThisWorkbook.Worksheets("Sheet1")
' Get ranges
Dim rng As Range
Set rng = wk.Range("A1").CurrentRegion
Dim Supplier As String, Header As String
Dim Period As Long
Dim Counter As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim r As Long
Dim c As Long
For c = 1 To rng.Columns.Count
For r = 1 To rng.Rows.Count
Counter = 0
Supplier = rng.Cells(r, 1).Value
Header = rng.Cells(1, c).Value
If rng.Cells(r, c).Interior.Color = 65535 Then
Counter = Counter + 1
dict(Header) = dict(Header) + Counter 'Adding the yellow values into the dictionary
dict(Supplier) = dict(Supplier) + Counter
End If
Next r
Next c
Dim LRow As Long
LRow = Cells(Rows.Count, 8).End(xlUp).row
' ClearData shReport
Sheets(1).Range("G1:I" & LRow).Clear
' Write the Header
Sheets(1).Range("G1").Resize(dict.Count, 1).Value = WorksheetFunction.Transpose(dict.Keys)
' Write the keys
Sheets(1).Range("H1").Resize(dict.Count, 1).Value = WorksheetFunction.Transpose(dict.Keys)
' Write the Items
Sheets(1).Range("I1").Resize(dict.Count, 1).Value = WorksheetFunction.Transpose(dict.Items)
' Clean up
Set dict = Nothing
End Sub