Markierte zellen in Diagramm übertragen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Function Chart_aufrufen(a As String, db As String) ' a = Worksheet, db sollte der Datenbereich sein Dim b As Double Dim c As Double Charts.Add ActiveChart.ApplyCustomType ChartType:=xlBuiltIn, TypeName:= _ "Farbige Linien" ActiveChart.SetSourceData Source:=Sheets(a).Range(db), PlotBy:=xlRows ActiveChart.Location Where:=xlLocationAsObject, Name:=a 'Muss mann das so machen wenn mann einen anderen Faktor haben will? b = ActiveSheet.ChartObjects(1).Height c = ActiveSheet.ChartObjects(1).Width ActiveSheet.ChartObjects(1).Height = b * 1.5 ActiveSheet.ChartObjects(1).Width = c * 1.5 With ActiveChart .HasTitle = True .ChartTitle.Characters.Text = "Liniendiagramm" .Axes(xlCategory, xlPrimary).HasTitle = False .Axes(xlValue, xlPrimary).HasTitle = False End With End Function

Sub Datenbereich_Chart() Dim a As Single Dim LoLetzte As Integer Dim rng As Range 'alle markierten Zellen durchlaufen For Each rng In Selection a = Selection.Find(What:=rng, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Row 'letzte verwendete Spalte benennen, dafür habe ich schon den halben Tag vergeudet LoLetzte = 256 LoLetzte = IIf(IsEmpty(Cells(a, 256)), Cells(a, 256).End(xlToLeft).Column, 256) MsgBox LoLetzte 'zum testen Next rng End Sub

Function FindDatabaseRange(startCell As Range) As String Dim lastRow As Long, lastCol As Integer lastRow = Cells(Rows.Count, startCell.Column).End(xlUp).Row lastCol = Cells(startCell.Row, 256).End(xlToLeft).Column FindDatabaseRange = Range(Cells(startCell.Row, startCell.Column), Cells(lastRow, lastCol)).Address End Function

Na, Na wer wird mir den hier Codeklau unterstellen ;-), nein Spaß bei Seite, den Code hab ich per Makrorekorder aufgezeichnet und dann den funktionsbedürfnissen angepasst.
Die untengenannten Zeilen hab ich nach langem rumprobieren dann auch rausbekommen. Allerdings bleiben mir dann immer Zweifel ob dies der effizienteste Weg ist.
ActiveSheet.ChartObjects(1).Height = b * 1.5
ActiveSheet.ChartObjects(1).Width = c * 1.5
Ich glaub mein größtes Problem liegt darin den Aufbau der Syntax zu verstehen, von wegen "Objektorientierte Programmierung". Das ist wie mit meinem englisch, ich verstehe es besser als das ich es reden kann.
Deine funktion ist auf jeden Fall näher dran als meine. ABER:
1. Fehler: sollten alle Spalten belegt sein, deshalb mein zugegeben ergoogelter Code
LoLetzte = 256
LoLetzte = IIf(IsEmpty(Cells(a, 256)), Cells(a, 256).End(xlToLeft).Column, 256)
Im Orginal war er mit Range anstatt Cells
2. markiert er das Datenfeld von C2:"letzte_Reihe,letzte_Spalte_C2"
Ich müsste aber einzelne Zellen in B:B(Linienbeschriftungen) markieren und diese zum Chart hinzufügen.
Bsp.
Markiert: B5, B8, B9, B13
Ergebnis: Range("B5:K5, B8:IT8, B9:G9,B13:IT13")
Wenn Du mir dabei weiterhelfen könntest wäre das Klasse!
Gruß
Stefan

Function GetDataBaseDescription() As String Dim i As Long, endCol As Integer Dim myC As Range, tmp1Range As Range, tmp2Range As Range Set tmp2Range = selection.Cells(1, 1) For Each myC In selection endCol = IIf(Not (IsEmpty(Cells(myC.Row, 256))), 256, Cells(myC.Row, 256).End(xlToLeft).Column) Set tmp1Range = Range(Cells(myC.Row, myC.Column), Cells(myC.Row, endCol)) Set tmp2Range = Application.Union(tmp2Range, tmp1Range) Next GetDataBaseDescription = tmp2Range.Address End Function

Hallo
"...Hab ich die Funktionen richtig aufgerufen, es funktioniert auf jeden Fall mal...."
Wenn es funktioniert ist es richtig. Ganz einfach.
In VBA es ist es wie in der Realität: Alle Wege führen nach Rom :-)
Trotzdem noch zwei kleinere Korrekturen :-)
Das Modul 1 sollte so aussehen

Option Explicit

Function Delete_Chart()
    ActiveSheet.ChartObjects.Delete
End Function

Function GetDataBaseDescription() As String
    Dim i As Long, endCol As Integer
    Dim myC As Range, tmp1Range As Range, tmp2Range As Range
    Set tmp2Range = Selection.Cells(1, 1)
    For Each myC In Selection
        endCol = IIf(Not (IsEmpty(Cells(myC.Row, 256))), 256, Cells(myC.Row, 256).End(xlToLeft).Column)
        Set tmp1Range = Range(Cells(myC.Row, myC.Column), Cells(myC.Row, endCol))
        Set tmp2Range = Application.Union(tmp2Range, tmp1Range)
    Next
    GetDataBaseDescription = tmp2Range.Address
End Function

Function Create_Chart(wksName As String, dbArea As String)
    Charts.Add
    With ActiveChart
        .ApplyCustomType ChartType:=xlBuiltIn, TypeName:="Farbige Linien"
        .SetSourceData Source:=Sheets(wksName).Range(dbArea), PlotBy:=xlRows
        .Location Where:=xlLocationAsObject, Name:=wksName
    End With
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Characters.Text = "Liniendiagramm"
        .Axes(xlCategory, xlPrimary).HasTitle = False
        .Axes(xlValue, xlPrimary).HasTitle = False
    End With
    With ActiveSheet.ChartObjects(1)
        .Height = .Height * 1.5
        'oder Fix
        '.Height = 450
        .Width = .Width * 1.5
        'oder fix
        '.Width = 750
    End With
End Function

Mit den fixen Angaben, ist das Chart einfach immer gleich gross
Der Code im Klassenmodul Tabelle1 dagegen so

Private Sub ToggleButton1_Change()
    If Me.ToggleButton1.Value = True Then
        Create_Chart ActiveSheet.Name, GetDataBaseDescription
    Else
        Delete_Chart ActiveSheet.Name
    End If
End Sub

Du siehst, ich habe die Codes umbenannt (Klare Aussage der Funktion :-) ) und etwas umgestellt.
Kannst du übernehmen oder auch nicht. ;-)
In der Funktion als solches ändert sich nichts.
Lediglich der Code ist, in meinen Augen, etwas klarer nachvollziehbar.
Gruss Rainer

Beliebteste Forumthreads (12 Monate)

Markierte zellen in Diagramm übertragen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Markierte zellen in Diagramm übertragen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread