lave histogram i VBA

har problemer med at få den til at oprette et histogram
her er hele min kode:

Sub Histogram()
Dim NoRows As Integer
Dim Startcell
Dim Slutcell
Dim productname



NoRows = 0

Startcell = ActiveCell.Offset(0, 1).Address
productname = ActiveCell.Value

Do Until IsEmpty(ActiveCell)

NoRows = NoRows + 1

If ActiveCell.Value <> ActiveCell.Offset(1, 0).Value Then
Slutcell = ActiveCell.Offset(0, 1).Address

Application.Run "ATPVBAEN.XLAM!Histogram", ActiveSheet.Range("$B$1:$B$9"), productname, ActiveSheet.Range("$C$1:$C$9"), False, False, True, False

productname = ActiveCell.Value
Startcell = ActiveCell.Offset(0, 1).Address
NoRows = 0
End If
ActiveCell.Offset(1, 0).Select
Loop

End Sub


den kører det hele igennem uden fejl, men opretter ikke noget histogram