histogram macro opretter nyt worksheet istedet for nyt sheet

jeg har et problem med at min macro opretter et nyt worksheet istedet for et nyt sheet, når den når til det sidste 2 tal i kolonne A giver den en fejl "histogram - invalid output option" og så opretter den et nyt worksheet med histogram over alle 3'erne

det jeg gerne vil have er at macroen laver et histogram over alle 1'erne (fra kolonne A) i et nyt sheet der hedder 1 og alle 2'erne i et nyt sheet der hedder 2 osv osv

her er koden:


Sub Macro1()

AddIns("Analysis ToolPak").Installed = True
AddIns("Analysis ToolPak - VBA").Installed = True
Dim startcell
Dim slutcell
Dim productname
Sheets("Sheet1").Activate

Range("A1").Select
ActiveCell.FormulaR1C1 = "1"
Range("A2").Select
ActiveCell.FormulaR1C1 = "1"
Range("A3").Select
ActiveCell.FormulaR1C1 = "1"
Range("A4").Select
ActiveCell.FormulaR1C1 = "1"
Range("A5").Select
ActiveCell.FormulaR1C1 = "1"
Range("A6").Select
ActiveCell.FormulaR1C1 = "1"
Range("A7").Select
ActiveCell.FormulaR1C1 = "1"
Range("A8").Select
ActiveCell.FormulaR1C1 = "1"
Range("A9").Select
ActiveCell.FormulaR1C1 = "1"
Range("A10").Select
ActiveCell.FormulaR1C1 = "2"
Range("A11").Select
ActiveCell.FormulaR1C1 = "2"
Range("A12").Select
ActiveCell.FormulaR1C1 = "2"
Range("A13").Select
ActiveCell.FormulaR1C1 = "2"
Range("A14").Select
ActiveCell.FormulaR1C1 = "2"
Range("A15").Select
ActiveCell.FormulaR1C1 = "2"
Range("A16").Select
ActiveCell.FormulaR1C1 = "2"
Range("A17").Select
ActiveCell.FormulaR1C1 = "3"
Range("A18").Select
ActiveCell.FormulaR1C1 = "3"
Range("A19").Select
ActiveCell.FormulaR1C1 = "3"
Range("A20").Select
ActiveCell.FormulaR1C1 = "3"
Range("A21").Select
ActiveCell.FormulaR1C1 = "3"
Range("A22").Select
ActiveCell.FormulaR1C1 = "3"
Range("A23").Select
ActiveCell.FormulaR1C1 = "3"
Range("A24").Select
ActiveCell.FormulaR1C1 = "3"
Range("B1").Select
ActiveCell.FormulaR1C1 = "1"
Range("B2").Select
ActiveCell.FormulaR1C1 = "2"
Range("B3").Select
ActiveCell.FormulaR1C1 = "1"
Range("B4").Select
ActiveCell.FormulaR1C1 = "1"
Range("B5").Select
ActiveCell.FormulaR1C1 = "2"
Range("B6").Select
ActiveCell.FormulaR1C1 = "3"
Range("B7").Select
ActiveCell.FormulaR1C1 = "3"
Range("B8").Select
ActiveCell.FormulaR1C1 = "4"
Range("B9").Select
ActiveCell.FormulaR1C1 = "2"
Range("B10").Select
ActiveCell.FormulaR1C1 = "1"
Range("B11").Select
ActiveCell.FormulaR1C1 = "1"
Range("B12").Select
ActiveCell.FormulaR1C1 = "2"
Range("B13").Select
ActiveCell.FormulaR1C1 = "2"
Range("B14").Select
ActiveCell.FormulaR1C1 = "2"
Range("B15").Select
ActiveCell.FormulaR1C1 = "3"
Range("B16").Select
ActiveCell.FormulaR1C1 = "4"
Range("B17").Select
ActiveCell.FormulaR1C1 = "4"
Range("B18").Select
ActiveCell.FormulaR1C1 = "4"
Range("B19").Select
ActiveCell.FormulaR1C1 = "3"
Range("B20").Select
ActiveCell.FormulaR1C1 = "2"
Range("B21").Select
ActiveCell.FormulaR1C1 = "2"
Range("B22").Select
ActiveCell.FormulaR1C1 = "1"
Range("B23").Select
ActiveCell.FormulaR1C1 = "2"
Range("B24").Select
ActiveCell.FormulaR1C1 = "3"
Range("D2").Select
ActiveCell.FormulaR1C1 = "1"
Range("D3").Select
ActiveCell.FormulaR1C1 = "2"
Range("D4").Select
ActiveCell.FormulaR1C1 = "3"
Range("D5").Select
ActiveCell.FormulaR1C1 = "4"
Range("D6").Select

Range("A1").Select
startcell = ActiveCell.Offset(0, 1).Address
productname = ActiveCell.Text

Do Until IsEmpty(ActiveCell)

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

Application.Run "ATPVBAEN.XLA!Histogram", ActiveSheet.Range(startcell, slutcell), _
productname, ActiveSheet.Range("$D$2:$D$5"), False, False, True, False

Sheets("Sheet1").Activate
productname = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(0, 4).Value = productname
startcell = ActiveCell.Offset(1, 1).Address
ActiveCell.Offset(0, 2).Value = startcell
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub

koden skulle være direkte til at smide ind i en macro og køre

håber i kan hjælpe