Dynamisk data i xy-punkt graf.

Det kunne jo godt være - har du en prøve på grundlag af ovenstående data - så må du godt sende dem.

Hvis vi antager, at du har dine væredier stående i et ark der hedder "Ark1", og Produktnr er placeret i A1, samt at du har grafen du vil opdatere som et ark der hedder "Diagram1", så kan du skrive følgende vb-kode i arket "Diagram1", og så vil den automatisk opdatere, hver arket med graffen bliver valgt.

Private Sub Chart_Activate()
    ActiveChart.SetSourceData Source:=Sheets("Ark1").Range("A1", Sheets("Ark1").Range("B65536").End(xlUp)), PlotBy:=xlColumns
End Sub

Håber at det giver mening :)

Rem - version 2 21-05-2008
Rem (Nulstilling fjernet)
Rem (DiagramArk navngives - evt. gl. "DiagramArk" slettes, hvis samme navn)

Const diaNavn = "Proceskontrol (Print)"
Dim sidsteRæk, ddStartRæk
Dim datoTab(), datoRæk, antalDatoer, sidsteDataRække
Private Sub worksheet_activate()
    Application.ScreenUpdating = False

    svar = MsgBox("Opbyg diagram?", vbYesNo)
    If svar = 6 Then
        opbygDiagram
        MsgBox ("DiagramOpbygning afsluttet")
    End If
   
    Application.ScreenUpdating = True
End Sub
Private Sub opbygDiagram()
Rem Test om diagramArk findes - hvis ja: Slet dette
    For Each sh In ActiveWorkbook.Sheets
        If LCase(sh.Name) = LCase(diaNavn) Then
            Application.DisplayAlerts = False
            sh.Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next
   
    sidsteRæk = findSidsteRække
   
    ddStartRæk = sidsteRæk + 5
    sletGlData sidsteRæk + 1
   
Rem opret tabel til datoer
    opretDatoTabel
End Sub
Private Function findSidsteRække()
    For ræk = 2 To 65000
        If Cells(ræk, 1) = "" Then
            findSidsteRække = ræk
            Exit Function
        End If
    Next
End Function
Private Sub sletGlData(fraRæk)
    ActiveSheet.Rows(CStr(fraRæk) & ":65000").Select
    Selection.Delete
End Sub
Private Sub opretDatoTabel()
Dim dato As Date
    ReDim datoTab(sidsteRæk)
   
    antalDatoer = 0
    For ræk = 2 To sidsteRæk
        If Cells(ræk, 2) <> "" Then
            dato = Cells(ræk, 2)
            placerItabel dato
        End If
    Next ræk
   
    datoSortering
    opbygFailProduct
    genererDiagram
End Sub
Private Sub placerItabel(dato)
    For ix = 0 To sidsteRæk - 1
        If datoTab(ix) = "" Then
            datoTab(ix) = dato
            antalDatoer = antalDatoer + 1
            Exit Sub
        Else
            If dato = datoTab(ix) Then
Rem dato findes i forvejen
                Exit Sub
            End If
        End If
    Next ix
End Sub
Private Sub datoSortering()
Dim dato As Date
    datoRæk = ddStartRæk
   
Rem placer datoer i Kol A
    For ix = 0 To sidsteRæk - 1
        If datoTab(ix) <> "" Then
            dato = datoTab(ix)
            Cells(datoRæk, 1) = dato
            datoRæk = datoRæk + 1
        Else
            Exit For
        End If
    Next ix
   
    Range("A" & CStr(ddStartRæk) & ":A" & CStr(datoRæk - 1)).Select
    Selection.NumberFormat = "m/d/yyyy"

    Selection.Sort Key1:=Range("A" & CStr(ddStartRæk)), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Copy

Rem Transponer datoer til overskrifter
    Range("B" & CStr(ddStartRæk)).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False
   
    Range("A" & CStr(ddStartRæk) & ":A" & CStr(datoRæk - 1)).Select
    Selection.ClearContents
End Sub
Private Sub opbygFailProduct()
Dim part, dato As Date, fejl
    For ræk = 2 To sidsteRæk
        If Cells(ræk, 1) <> "" Then
            part = Cells(ræk, 1)
            dato = Cells(ræk, 2)
            fejl = Cells(ræk, 10)
            placerFejl ræk, part, dato, fejl
        Else
            Exit For
        End If
    Next ræk
End Sub
Private Sub placerFejl(pRæk, part, dato As Date, fejl)
On Error GoTo fejl
    For ræk = ddStartRæk + 1 To 65000
        If Cells(ræk, 1) = part Then
            kol = findDatoKol(dato)
            Cells(ræk, kol) = fejl
            Exit Sub
        Else
            If Cells(ræk, 1) = "" Then
                Cells(ræk, 1) = part
                kol = findDatoKol(dato)
                Cells(ræk, kol) = fejl
                sidsteDataRække = ræk
                Exit Sub
            End If
        End If
    Next ræk
    Exit Sub

fejl:
    MsgBox ("Fejl - kontakt udvikler")
    Stop
End Sub
Private Function findDatoKol(dato)
    For kol = 2 To antalDatoer + 1
        If dato = Cells(ddStartRæk, kol) Then
            findDatoKol = kol
            Exit Function
        End If
    Next kol
    findDatoKol = 0
End Function
Private Sub genererDiagram()

    Range(Cells(ddStartRæk, 1), Cells(sidsteDataRække, antalDatoer + 1)).Select
   
    Charts.Add
    ActiveChart.ChartType = xlXYScatterLines
    ActiveChart.SetSourceData Source:=Sheets("DATAARK Dagsniveau (Print)").Range( _
        Cells(ddStartRæk, 1), Cells(sidsteDataRække, antalDatoer + 1)), PlotBy:=xlRows
    ActiveChart.Location Where:=xlLocationAsNewSheet
    With ActiveChart
        .HasTitle = False
        .Axes(xlCategory, xlPrimary).HasTitle = False
        .Axes(xlValue, xlPrimary).HasTitle = False
    End With
   
Rem Navngiv arket
    ActiveSheet.Name = diaNavn
End Sub