Links i graf

Se venligst bort fra ovenstående. Det var ikke så klart formuleret og ikke helt korrekt. På dette link har jeg lavet et eksempel:
http://img527.imageshack.us/my.php?image=graf2kk7.gif
Langs x aksen fremgår der nogle grønne markeringer, der skal illustrere at der er sket noget bestemt her. Jeg vil gerne have det sådan, at hvis man trykker på en af disse markeringer, så kommer man over til en tabel i Ark 2 og den transaktion, som er til grund for markeringen.
Kan det lade sig gøre i excel?

Det må gerne være noget lig med:
http://www.euroinvestor.dk/Stock/ShowStockInfo.aspx?StockId=395356
Kig nederst under overskrifter Graf/kursudvikling og sæt tidsperioden til 2 uger. Du kan her se, at der er nogle blå kasser med et "i" inden i over grafen. Det er lidt samme princip, som jeg gerne vil have ført over. Hvis man trykker på disse kasser, kommer nyheden frem. Her vil jeg bare gerne føres over til et bestemt transaktion på et andet faneblad.

Jeg er næsten sikker på, at der findes en løsning på dit problem, hvis du kan acceptere, at du skal klikke på grafen for et aktivere den rette celle.

Hvis du skal bruge den nedenfor beskrevne løsning, skal du bruge et chart, som er tilføjet som et ark.

Under disse chart’s findes nemlig en række events.
Højreklikker du på Sheet/chart-fanen kan du bede om at se koden for arket eller chart’et,

Herinde er der mulighed for at arbejde med en række events.

Du skal bruge følgende event, som du kan vælge fra dropdown menuen øverst i kodearket:

Private Sub Chart_Select(ByVal ElementID As Long, _
  ByVal Arg1 As Long, ByVal Arg2 As Long)

Dette omformes til


  Private Sub Chart_Select(ByVal ElementID As Long, _
  ByVal Arg1 As Long, ByVal Arg2 As Long)
  If ElementID = xlSeries Then
        serie = Arg1
        punkt = Arg2
        rangeForGraf = ActiveChart.SeriesCollection(serie).Formula
       
        'rangeForGraf skal tykkes igennem og område findes.
        'punkt x må være den x'te celle i range for grafen.
        'hvis  adresse for  grafen er "adr"
        'vil range(adr)(punkt) være den adresse du skal aktivere
       
    End If
  End Sub
Eventen aktiveres hvis du klikker på chartet.
Rammer du en serie og et punkt ryger du inde i if-sætningen og får punkt og serie retuneret

”rangeForGraf” skal tykkes igennem og område findes.
Punkt x må være den x'te celle i range for grafen.

Hvis  adresse for  grafen er "adr"  vil range(adr)(punkt) være den adresse du skal aktivere.


Du kan evt. bruge nedenstående som inspiration til at tykke ”rangeForGraf” igennem.



Function GetChartRange(cht, series, ValOrX) As Range
'  cht: A Chart object
'  series: Integer representing the Series
'  ValOrX: String, either "values" or "xvalues"

    Dim Sf As String
    Dim CommaCnt As Integer
    Dim Commas() As Integer
    Dim ListSep As String * 1
    Dim Temp As String
   
    Set GetChartRange = Nothing
    On Error Resume Next
   
'  Get the SERIES formula
    Sf = cht.SeriesCollection(series).Formula
   
'  Check for noncontiguous ranges by counting commas
'  Also, store the character position of the commas
    CommaCnt = 0
    ListSep = ","
    For i = 1 To Len(Sf)
        If Mid(Sf, i, 1) = ListSep Then
            CommaCnt = CommaCnt + 1
            ReDim Preserve Commas(CommaCnt)
            Commas(CommaCnt) = i
        End If
    Next i
    If CommaCnt > 3 Then Exit Function
   
'  XValues or Values?
    Select Case UCase(ValOrX)
        Case "XVALUES"
'          Text between 1st and 2nd commas in SERIES Formula
            Temp = Mid(Sf, Commas(1) + 1, Commas(2) - Commas(1) - 1)
            Set GetChartRange = Range(Temp)
        Case "VALUES"
'          Text between the 2nd and 3rd commas in SERIES Formula
            Temp = Mid(Sf, Commas(2) + 1, Commas(3) - Commas(2) - 1)
            Set GetChartRange = Range(Temp)
    End Select
End Function

Sub ShowSeries1()
    Set MyChart = ActiveChart
    Set xv = GetChartRange(MyChart, 1, "xvalues")
    Set v = GetChartRange(MyChart, 1, "values")
    Msg = "XValues: " & vbTab & xv.Address & vbCrLf
    Msg = Msg & "Values: " & vbTab & v.Address
    MsgBox Msg, vbInformation, "Series 1"
End Sub

Sub ShowSeries2()
    Set MyChart = ActiveChart
    Set xv = GetChartRange(MyChart, 2, "xvalues")
    Set v = GetChartRange(MyChart, 2, "values")
    Msg = "XValues: " & vbTab & xv.Address & vbCrLf
    Msg = Msg & "Values: " & vbTab & v.Address
    MsgBox Msg, vbInformation, "Series 2"
End Sub

Det lyder meget godt, men jeg har slet ikke styr på VBA, så jeg ved ikke hvor jeg skal starte og slutte med "range for graf". Det vil ellers være lækkert hvis det kan løses på den måde, men jeg har brug for en færdig løsning, der kan indsættes. Jeg kan oplyse de ting som er nødvendige, hvis du beskriver hvad du skal bruge.

Jeg kan sagtens lave det for dig. Men jeg er lidt i tidsnød ligenu.
Jeg vil gerne kikke på det i løbet af de næste 2 uger, hvis det er tidsnok for dig.

Måske andre kan hjælpe?

Hvis ikke andre kan hjælpe så send mig dit materiale. Så kikker jeg på det, men det bliver ikke lige nu.
Min mailadresse er
michael.koppelgaard@gmail.com

Nå hvad siger du ?

Mail er sendt.

Mærkeligt jeg har ikke fået den endnu??

Men jeg skriver også eksamensopgave og har supertravlt. Men så snart jeg er færdig, så vender jeg tilbage !!

Mærkeligt. Du kan prøve at maile mig på henne (a) webspeed.dk, så kan jeg svare på den.

Du mener henne@webspeed.dk?

Jo men når man skriver sin mail på offentlige sider, er man næsten sikker på at blive ramt af spammails. Hvis man laver fx @ om, så kan mailen ikke automatisk læses.

Sendt igen.

Jeg har en løsning til dig som jeg lægger ud når du har godkendt den.
Jeg sender den nu.

Michael

Jeg har sendt endnu en løsning til dig.
Spændt på, hvad du mener om.
Jeg synes den er rigtig god.

Michael

Jeg  har sendt endnu en løsning til dig.
Michael

Hej Henrik
Her er arket til dig.
Håber virkelig på at det er ok.

Når du trykker shift exc, kan ophæver du kørsel af makroen, så du let kan rykke tekstboksen.
Chartarea er derimod låst og kan kun ændre udseende gennem koden:


Sub setPlotArea()
    Dim plotAr As PlotArea
 
    Set plotAr = ActiveChart.PlotArea
    plotAr.Height = 420
    plotAr.Width = 630
    plotAr.Left = 1
    plotAr.Top = 6

End Sub

Hvis du ændre på plotarea skal du samtiden justere koden :

Const xMin = 79 'aflæses ved statusbar nederst tv på kurve
Const xMax = 1096 'aflæses ved statusbar nederst tv på kurve
xMin aflæses i nederste venstre hjørne ved at holde mus hen over første punkt .
xMax aflæses i nederste venstre hjørne ved at holde mus hen over sidste punkt .

Sagen er nemlig det at punktet flytter sig efter en beregning, som er følgende

Function beregnPunkt(x As Long) As Double
    antalPunkter = ActiveChart.SeriesCollection(1).Points.Count
    afstandPunkter = (xMax - xMin) / (antalPunkter - 1)
    punktDbl = (x - xMin) / afstandPunkter
    beregnPunkt = Round(punktDbl, 0) + 1

End Function

Aktiveret af makroen:

Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
som reagere på mousemove.

Når du trykker musen ned ryger du ind i ark2 i til den bemærkning som høre til punktet.

Cirklen kan jeg ikke justere bedre end jeg allerede har gjort.
Du kan selv prøve, om du kan gøre det bedre ved at ændre på xMax og xMin.


Spændt på hvad du siger.


Michael

Kode under "Diagram 1"
Dim sidstePunkt As Long
Dim tmp As Boolean ' for at undgå at cirkel fjernes når cht aktivers under showPointValue
Const xMin = 79 'aflæses ved statusbar nederst tv på kurve
Const xMax = 1096 'aflæses ved statusbar nederst tv på kurve

Private Sub Chart_Activate()
    If tmp = True Then Exit Sub
    With ActiveChart.SeriesCollection(1)
        .MarkerBackgroundColorIndex = xlNone
        .MarkerForegroundColorIndex = xlNone
    End With


End Sub


Private Sub Chart_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    Dim punkt As Long
    Dim rng As Range, rngDato As Range
    On Error Resume Next
   
    punkt = beregnPunkt(x)
    If Not Shift = 2 Then Exit Sub
    Set rngDato = pointXRng(punkt)
    Sheets(2).Activate
    Application.ScreenUpdating = True
    Cells.Find(What:=rngDato.Value, After:=Range("C1"), LookIn:=xlValues, lookat:=xlWhole).Select
     
    ActiveCell.Offset(, 3).Select

End Sub

Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    Dim punkt As Long
    On Error Resume Next
    Application.StatusBar = x
    If ThisWorkbook.kørIkkeMakro = True Then Exit Sub
    Application.ScreenUpdating = False
    setPlotArea
    punkt = beregnPunkt(x)
    Call pointMarker(1, punkt)
    Call showPointValue(punkt)

End Sub

Private Sub pointMarker(serie As Long, punkt As Long)
    On Error Resume Next
    Application.ScreenUpdating = False
    ActiveChart.SeriesCollection(serie).Points(sidstePunkt).MarkerForegroundColorIndex = xlNone
    ActiveChart.SeriesCollection(serie).Points(punkt).MarkerForegroundColorIndex = xlAutomatic
    ActiveChart.SeriesCollection(serie).Points(punkt).MarkerSize = 8
    sidstePunkt = punkt

End Sub


Private Sub showPointValue(point As Long)
    Dim rng As Range

    Set cht = ActiveChart
    chtRng = cht.SeriesCollection(1).Formula
    a = Split(chtRng, delimiter:=",")
    x = a(0)
    xRng = a(1)
    yRng = a(2)

    tæller = 1
    For Each c In Range(xRng)
        If tæller = point Then Exit For
        tæller = tæller + 1
    Next
    dato = c.Value 'dato
   
    Set cht = ActiveChart
    Sheets(2).Select
    Set rng = Sheets(2).Cells(1, 3)
   
    bemærk = Cells.Find(What:=dato, After:=Cells(1, 3), LookIn:=xlValues, _
        lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Offset(, 3)
       
    tmp = True
    cht.Select
    tmp = False
    tæller = 1
    For Each c In Range(yRng)
        If tæller = point Then Exit For
        tæller = tæller + 1
    Next
    yval = c.Value
   

    ActiveChart.Shapes("Text Box 1").Select
    Selection.Characters.Text = bemærk
    ActiveChart.PlotArea.Select



End Sub


Private Function pointXRng(point As Long) As Range

    Dim arr(3) As String
    Set cht = ActiveChart
    chtRng = cht.SeriesCollection(1).Formula
    a = Split(chtRng, delimiter:=",")

    xRng = a(1)
    yRng = a(2)

    tæller = 1
    For Each x In Range(xRng)
        If tæller = point Then Exit For
        tæller = tæller + 1
    Next
    xval = x.Value 'datp

    Set pointXRng = x

End Function


Sub setPlotArea()
    Dim plotAr As PlotArea
   
    Set plotAr = ActiveChart.PlotArea
    plotAr.Height = 420
    plotAr.Width = 630
    plotAr.Left = 1
    plotAr.Top = 6

End Sub


Function beregnPunkt(x As Long) As Double
    antalPunkter = ActiveChart.SeriesCollection(1).Points.Count
    afstandPunkter = (xMax - xMin) / (antalPunkter - 1)
    punktDbl = (x - xMin) / afstandPunkter
    beregnPunkt = Round(punktDbl, 0) + 1

End Function



Kode under thisWorkbook:
Public kørIkkeMakro As Boolean
Private Sub Workbook_Open()
    Set cht = ThisWorkbook.Charts("Diagram1")
    With cht.SeriesCollection(1)
        .MarkerBackgroundColorIndex = xlNone
        .MarkerForegroundColorIndex = xlNone
    End With
    Application.OnKey "+{ESCAPE}", "ThisWorkbook.Sub_kørIkkeMakro"

End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
    Application.StatusBar = False
End Sub

Sub Sub_kørIkkeMakro()
    If kørIkkeMakro = True Then
        kørIkkeMakro = False
    ElseIf kørIkkeMakro = False Then
        kørIkkeMakro = True
    End If
End Sub

FLOT ARBEJDE!