Trying to loop to format data for graphing - excel

Question

I've been working on this for a bit, and I've just come to a roadblock. I'm trying to format some data for graphing in Excel, and it looks like this:
Example Data
I'd like to have the output look like this:
Desired Output
The actual number of faults and days vary wildly, so it has to be open-ended, so it can do a full search of the imported file. I'm trying to do it using VBA without relying on a formula.
Let me know if there's anything I could be doing different.
Here's the code:
Sub Graph()
Dim GraphDataWS, DataWS, FormWS As Worksheet
Dim criteria1, InspectedMtr As String
Dim totalrow, ErrorRangevar, DateRangeVar, Row1, Col1 As Long
Dim Daterange, ErrorRange As Range
Dim criteria2 As Variant
Dim ErrorCount, Output As Double
Worksheets("Graph Data").Activate
Set Worksheet = ActiveWorkbook.Sheets("Graph Data")
Cells.Select
Selection.ClearContents
Selection.ClearContents
Set GraphDataWS = ActiveWorkbook.Sheets("Graph Data")
Set FormWS = ActiveWorkbook.Sheets("Formulas")
Set DataWS = ActiveWorkbook.Sheets("Data")
totalrow = FormWS.Range("A21").Value
Worksheets("Data").Range("A1:A" & totalrow).SpecialCells(xlCellTypeVisible).Copy (Worksheets("Graph Data").Range("B1"))
Worksheets("Data").Range("E1:E" & totalrow).SpecialCells(xlCellTypeVisible).Copy (Worksheets("Graph Data").Range("A1"))
With GraphDataWS
ErrorRangevar = GraphDataWS.Cells(Rows.Count, "A").End(xlUp).Row
GraphDataWS.Range("A1:A" & ErrorRangevar).Copy (GraphDataWS.Range("C1:C" & ErrorRangevar))
GraphDataWS.Range("C2:C" & ErrorRangevar).RemoveDuplicates Columns:=1
DateRangeVar = GraphDataWS.Cells(Rows.Count, "B").End(xlUp).Row
GraphDataWS.Range("B1:B" & DateRangeVar).Copy (GraphDataWS.Range("D1:D" & DateRangeVar))
GraphDataWS.Range("D2:D" & DateRangeVar).RemoveDuplicates Columns:=1
'DateRangeVar = GraphDataWS.Cells(Rows.Count, "B").End(xlUp).row
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ErrorRangevar = ErrorRangevar + 2
Worksheets("Graph Data").Activate
Output = 0
Set Daterange = GraphDataWS.Range(Cells(1, 4), Cells(1, DateRangeVar))
Set ErrorRange = GraphDataWS.Range("C1:C" & ErrorRangevar)
For a = 2 To ErrorRangevar
criteria1 = Cells(a, 3).Value
For b = 2 To ErrorRangevar
criteria2 = Cells(a, 4).Value
For i = 2 To ErrorRangevar
If ((Cells(i, 1)) = criteria1) And (Cells(i, 2) = criteria2) Then
Output = Output + 1
End If
Next i
Row1 = ErrorRange.Find(What:=criteria1).Row
Col1 = Daterange.Find(What:=criteria2).Column
Cells(Row1, Col1).Value = Output
MsgBox criteria1 & " " & Row1 & " " & criteria2 & " " & Col1 & " Output: " & Output
Output = 0
Next b
Next a
GraphDataWS.Range("E2").Value = Output
End With
End Sub
Any other suggestions or comments are welcome, I'm still learning VBA/Excel. Thank you!

Answer 1

First, I'm sorry as I can't understand this sentence :
to graph information from that
porting the information from a table
Anyway, other than create a pivot table from the data seen in your first image to get the expected result as seen in your second image ... I try to make the code based on the data seen in your first image to get the expected result as seen in you second image.
Sub test()
Dim rgdt As Range: Dim dateCol As Range: Dim cell As Range
Dim rgdt1 As String: Dim rgdt2 As String
Set rgdt = Sheets("Sheet1").UsedRange
Set rgdt = rgdt.Resize(rgdt.Rows.Count - 1, rgdt.Columns.Count).Offset(1, 0)
rgdt1 = "Sheet1!" & rgdt.Columns(1).Address
rgdt2 = "Sheet1!" & rgdt.Columns(2).Address
With Sheets("Sheet2").Range("A1")
.Value = "NAME"
rgdt.Copy Destination:=.Offset(1, 0)
.Range(rgdt.Columns(1).Address).RemoveDuplicates Columns:=1, Header:=xlNo
.Range(rgdt.Columns(2).Address).RemoveDuplicates Columns:=1, Header:=xlNo
Set dateCol = .Range(rgdt.Columns(2).Address).SpecialCells(xlConstants)
dateCol.Copy
.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
dateCol.Clear
For Each cell In .Range(rgdt.Columns(1).Address).SpecialCells(xlConstants)
With cell.Offset(0, 1).Resize(1, dateCol.Rows.Count)
.Value = "=countifs(" & rgdt1 & "," & cell.Address & "," & rgdt2 & ",B$1)"
.Value = .Value
.Replace What:=0, Replacement:="", MatchCase:=True
End With
Next
End With
End Sub
The sub assumed that there is nothing else in "Sheet1" but the data seen in your example data image.
First it create rgdt variable as the range of the data in "Sheet1" (sheet "Data" in your case, so change accordingly) without including the header.
Then it create rgdt1 and rgdt2 string variable to point which sheet and which column of rgdt.
Then it prepares the "skeleton" of expected result in "Sheet2" (Sheet "Graph Data" in your case):
fill cell A1 with "NAME"
copy the rgdt to cell A1.offset(1,0)
remove duplicate value in column A
remove duplicate value in column B
set the range of column B with data as dateCol variable (without the header)
copy the dateCol and paste transpose to cell A1.offset(0,1)
clear the value in dateCol
Next, it populate the value for the expected count result by looping to each cell which has value in column A, where on each loop it fill the range of cells after the looped cell to the right with COUNTIFS formula, remove the formula as value, then replace zero (0) result with nothing.
If you want to test the sub, create a new workbook, copy your data into cell A1 of "Sheet1", copy also the sub, then run the sub. See the expected result in "Sheet2".