Office: (Office 2010) VBA Graph erstellen mit wechselnden unterschiedlich langen Abschnitten

Hallo liebe Office-Hilfe.com-Gemeinde,
Ich habe dieses Forum ausgewählt, da ich hier den Eindruck von echtem Fachwissen gepaart mit gutem Umgang miteinander vorfinde.
Und nach zahlreichen passiven Besuchen zur Selbstbildung in Richtung VBA ist dies ist mein erster Eintrag, da ich nun nicht mehr weiterkomme.

Zum Hintergrund: es geht um Lieferpläne.

Ich habe folgendes Problem:
Ich habe eine Tabelle aufbereitet die aus mehreren Blöcken besteht (Level: siehe Spalte A 'Verkettung 1'). Ein solcher Block ergibt sich aus einer 'Bestellnummer' und einer 'Bestellposition'. Also hier z.B. das Ventil.
Innerhalb eines solchen Blocks gibt es chronologische Abrufnummern (Sp. G). Aus dieser Information ergibt sich die ‚Verkettung 2‘ (Sp. B).
Die Abrufnr. (Sp. G) zeigt den einen Abruf mit all seinen Lieferdaten.
Ich habe es nach Größe sortiert – also oben steht der aktuellste Abruf, in diesem Fall der 6. Abruf (das bedeutet, der Lieferplan hat sich schon 6 mal geändert).

Nun möchte ich aus dieser Excel-Tabelle eine graphische Übersicht erstellen. Und zwar für den aktuellsten Abruf einer ‚Verkettung 1‘. Also den maximalen Wert der ‚Verkettungen 2‘ innerhalb der ‚Verkettung 1‘.
Dabei sollen alle Lieferdaten und kumulierten Mengen (Neu & Alt) übernommen werden, um sie dann graphisch zu vergleichen.
Im Ergebnis hätte ich dann gerne alle Graphen mit Übersichten von den verschiedenen Bauteilen untereinander in einem neuen Arbeitsblatt (variable Länge der Lieferpläne und damit varibler Startpunkt des nächsten Graphen).

Ich habe schon ein Makro aufgezeichnet das für den ersten Block macht was ich möchte, aber ich bekomme es nicht hin es zu verallgemeinern.
Es müsste ja irgendwie folgende Definition sein: Wenn sich 'Verkettung 1' ändert, dann ersten Block der nächsten Verkettung übernehmen.

Ich bedanke mich schon einmal vorab für mögliche Antworten!

Ps.: eine weitere Frage habe ich zu der Färbung. Ich habe es hier nur hinbekommen, dass ich Zeilen mit gerade Abrufnummern blau färbe, so ergibt sich aber, wie auch hier, dann ein Sprung zwischen den Bestellnummern. Wie kann man das lösen?

 

Hi,

und wo ist dein aufgezeichnetes Makro?

Bis später,
Karin

 

Hallo Karin,
Vielen Dank für deine Antwort.

Ich hoffe meine Problembeschreibung war nicht zu detailliert - ist vllt etwas viel Background dabei.
Worum es mir zusammengefasst geht, ist ein kleines Programm, dass mir erlaubt, diese Übersicht mit Graphen und Tabellen für die verschiedenen Bauteile (Ventil usw.) untereinander darzustellen. Das Problem dabei ist, dass die Tabellen aufgrund der Lieferplaneigenschaften unterschiedlich lang sein können. Die Graphen und Tabellen müssten also variable Startpunkte haben.

Ich hoffe sehr auf deine Hilfe, ich komme echt nicht weiter ... :-(

 

Hier ist mein Makro für das Erstellen der Tabelle und des Graphen:

Sub Tabelle_und_Graph()
'
' Tabelle_und_Graph Makro
'

'
Sheets("Tabelle1").Select
Range("L1:O1").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("F4").Select
ActiveSheet.Paste
Sheets("Tabelle1").Select
Application.CutCopyMode = False
Range("L2:O17").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("F5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F4:I20").Select
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("F4:H20").Select
ActiveSheet.Shapes.AddChart2(332, xlLineMarkers).Select
ActiveChart.SetSourceData Source:=Range("Tabelle2!$F$4:$H$20")
ActiveSheet.Shapes("Diagramm 2").IncrementLeft 276
ActiveSheet.Shapes("Diagramm 2").IncrementTop -27
Range("G4").Select
ActiveCell.FormulaR1C1 = "Kumulierte Menge Neu"
Range("G5").Select
End Sub

 

Und hier das Makro für die Erstellung der Übersicht (hier schon auf english):
(VORSICHT, beim kopieren des Makros beachten: ich musste bei allen Zeilen mit der Spalte D ein Leerzeichen einfügen, da er mir da sonst überall Smilies einsetzt)

Sub Results_Maske_NEU()
' Results_Maske_NEU Makro
Dim ersterBlock As Long
Dim i, w_flag As Long
Dim Counter, rep_cnt As Long

Range("A3").Select
ActiveCell.FormulaR1C1 = "Order No."
Range("B3").Select
ActiveCell.FormulaR1C1 = "Order Pos."
Range("C3: D3").Select
ActiveCell.FormulaR1C1 = "Article Description"
Range("C4: D4").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C5").Select
ActiveCell.FormulaR1C1 = "Current"
Range("D5").Select
ActiveCell.FormulaR1C1 = "Replaced"
Range("B6").Select
ActiveCell.FormulaR1C1 = "Del. Instr. No."
Range("B7").Select
ActiveCell.FormulaR1C1 = "Del. Instr. Date"
Range("B8").Select
ActiveCell.FormulaR1C1 = "Revision"
Range("B9").Select
ActiveCell.FormulaR1C1 = "latest fix Date"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Cum. Del. Qty. C."
Range("A12").Select
ActiveCell.FormulaR1C1 = "Latest"
Range("C12").Select
ActiveCell.FormulaR1C1 = "Del.note Date"
Range("B12").Select
ActiveCell.FormulaR1C1 = "Del.note No."
Range("D12").Select
ActiveCell.FormulaR1C1 = "Del.note Qty."
Range("A12").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A3: D3").Select
Selection.Font.Bold = True
Range("C5: D5").Select
Selection.Font.Bold = True
Range("B6:B10").Select
Selection.Font.Bold = True
Range("B5: D10").Select
Range("A12: D13").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("B5: D10").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A3: D3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A3: D4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Range("A3: D13").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D: D").EntireColumn.AutoFit
Columns("A:A").EntireColumn.AutoFit
Columns("A:A").ColumnWidth = 11.29
Range("A3:B4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Range("C5: D10").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Sub Results_Graph()
'
' Results_Graph Makro
'

'Maske fuellen
Sheets("Tabelle1").Select
Range("C2").Select
Selection.Copy
Sheets("Tabelle3").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("F2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("C4: D4").Select
ActiveSheet.Paste
Sheets("Tabelle1").Select
ActiveWindow.SmallScroll ToRight:=2
Range("I2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("K2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("D6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("J2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("C7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("L2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("D7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C8").Select
Sheets("Tabelle1").Select
Range("G2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("M2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("D8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("V2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("C9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("W2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("D9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C7: D7,C9:D9").Select
Range("C9").Activate
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Sheets("Tabelle1").Select
Range("Q2").Select
Selection.Copy
Sheets("Tabelle3").Select
Range("C10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("R2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("D10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("N2:P2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("B13").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C13").Select
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Range("D13").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

'Tabelle und Graph erstellen
Columns("E:E").ColumnWidth = 3.43
Sheets("Tabelle1").Select
ActiveWindow.SmallScroll Down:=-18
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
Range("S2:S17").Select
Selection.Copy
Sheets("Tabelle3").Select
Range("F4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F3").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Del. Date"
Range("G3").Select
ActiveCell.FormulaR1C1 = "Cum. Qty. Current"
Range("H3").Select
ActiveCell.FormulaR1C1 = "Cum. Qty. Repl."
Range("I3").Select
ActiveCell.FormulaR1C1 = "Delta"
Range("G3").Select
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
Range("F3:I3").Select
Range("I3").Activate
Selection.Font.Bold = True
Sheets("Tabelle1").Select
Range("AC2:AC17").Select
Selection.Copy
Sheets("Tabelle3").Select
Range("G4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("AD2:AD17").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("H4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Tabelle1").Select
Range("AE2:AE17").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Tabelle3").Select
Range("I4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("F:F").Select
Selection.NumberFormat = "m/d/yyyy"
Range("F3:I19").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("J3").Select
Columns("J:J").ColumnWidth = 3.71
Range("F3:H19").Select
ActiveSheet.Shapes.AddChart2(332, xlLineMarkers).Select
ActiveChart.SetSourceData Source:=Range("Tabelle3!$F$3:$H$19")
'ActiveSheet.Shapes("Diagramm 2").IncrementLeft 178.5
'ActiveSheet.Shapes("Diagramm 2").IncrementTop -149.25

End Sub

 

Hier mein Lösungsvorschlag:

Code:

Sub DiaTabErstellen()
    Dim lngLetzte As Long
    Dim lngZiel As Long
    Dim lngEnde As Long
    Dim lngZeile As Long
    Dim lngAnzahl As Long
    lngZiel = 4
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Application.ScreenUpdating = False
    For lngZeile = 2 To lngLetzte
        With Worksheets("Tabelle2")
            lngEnde = lngZeile + Application.CountIf(Columns(2), Cells(lngZeile, 2)) - 1
            lngAnzahl = lngEnde - lngZeile
            Range("L1:O1").Copy .Cells(lngZiel, 6)
            .Cells(lngZiel, 7) = .Cells(lngZiel, 7).Value & " Neu"
            lngZiel = lngZiel + 1
            Range(Cells(lngZeile, 12), Cells(lngEnde, 15)).Copy
            .Cells(lngZiel, 6).PasteSpecial Paste:=xlValues
            With .ChartObjects.Add(0, 0, 0, 0).Chart
                .ChartType = xlLineMarkers
                .SetSourceData Source:=Range("Tabelle2!G" & lngZiel - 1 & ":H" & lngZiel + lngAnzahl), PlotBy:=xlColumns
                Range("Tabelle2!F" & lngZiel & ":F" & lngZiel + lngAnzahl).NumberFormat = "dd/mm/yyyy"
                .SeriesCollection(1).XValues = Range("Tabelle2!F" & lngZiel & ":F" & lngZiel + lngAnzahl)
                .Parent.Top = .Parent.Parent.Cells(lngZiel - 1, 11).Top
                .Parent.Left = .Parent.Parent.Cells(lngZiel, 11).Left
                .Parent.Height = 180
                .Parent.Width = 300
                .Legend.Position = xlBottom
            End With
            DoEvents
        End With
        lngZeile = lngEnde
        lngZiel = lngZiel + lngAnzahl + 3
    Next lngZeile
    Application.ScreenUpdating = True
End Sub

Code muss ausgeführt werden wenn Tabelle1 aktiv ist.

Bis später,
Karin

 

Hi Karin,

Vielen Dank für deine Hilfe! Das Licht am Ende des Tunnels wird heller und heller :D
Dein Code funktioniert schon einmal super und macht was er soll.

Kannst du mir jetzt noch dabei helfen, dass nur die aktuellste Abrufnummer kopiert wird?
Also beim Ventil beispielsweise nur der Block mit der Abrufnr. '6' (Sp G), bei der Buchse nur die '7' (Sp G) und beim Lager nur die '9'.

Meiner Meinung nach gibt es da zwei Möglichkeiten (wahrscheinlich findest du noch eine bessere):
- man kopiert nur den Block mit dem maximalen Wert in Sp. G unter der Voraussetzung, dass 'Verkettung 1' gleich bleibt
oder
- man kopiert den ersten Block (das ist möglich, weil die Blöcke sortiert sind) von 'Verkettung 1'

Wirklich vielen Dank!

Beste Grüße,
Jan

 

Hi Jan,

ich habe den Code nach deiner Mappe geschrieben, also immer die zusammenhängenden Blöcke werden kopiert - wenn du das jetzt anders haben möchtest, musst du den Code entsprechend anpassen. Andere Möglichkeit: du kopierst alle Daten, für die Diagramme erstellt werden sollen in eine Hilfstabelle und lässt den Code dann darüber laufen.

Bis später,
Karin

 

Hi Karin,

Nochmals Danke für deine Antwort.

Dass die zusammenhängenden Blöcke kopiert werden ist super und auch richtig so.
Daran möchte ich nichts ändern.
Ich bräuchte nur die Möglichkeit, dass das Programm immer nur den aktuellsten Block, also den aktuellsten Lieferplanabruf, kopiert und daraus den Graphen erstellt. Für das Ventil wären dass dann "nur" die Zeilen 2-17.
Insgesamt müsste das Programm dann für meine hochgeladene Beispieldatei nur 3 Graphen produzieren.
Weißt du was ich meine?

Echt vielen Dank für deine Zeit und Geduld!

Beste Grüße,
Jan

 

Hi Jan,

ändere diese Zeile

Code:

lngZeile = lngEnde

in diese

Code:

lngZeile = lngZeile + Application.CountIf(Columns(1), Cells(lngZeile, 1))

Bis später,
Karin

 

Hi Karin,

Das ist jetzt schon super nah dran.
Beim Ventil funktioniert alles perfekt!
Allerdings scheint sich bei der weiteren Auswahl etwas zu verschieben.
Denn bei der Buchse werden in der Tabelle statt den Zeilen 114-127, die Zeilen 115-128 übernommen.
Beim Lager werden statt den korrekten Zeilen 222-231, die Zeilen 224-233 übernommen.
Der Bereich scheint sich also immer n+1 zu verschieben. Also bei der Buchse dann insgesamt nur +1, beim Lager dann schon +2.

Weißt du woran das liegen könnte?

1000 Dank nochmal für deine tolle Unterstützung.

Beste Grüße,
Jan

 

Hi Jan,

ergänze bei der geänderten Zeile am Ende noch - 1

Ich hatte nicht berücksichtigt, dass durch Next lngZeile der Zähler lngZeile nochmal um 1 erhöht wird.

Bis später,
Karin

 

Hi Karin,

Perfekt!! Alles funktioniert! :D
Und ich konnte es super adaptieren.

Vielen, vielen Dank Karin!

Beste Grüße,
Jan

 

Hi Karin,

Mir ist leider noch ein Problem aufgefallen und ich hoffe du kannst mir nochmal helfen...
Und zwar gibt es Lieferpläne die kürzer sind als bei den 3 Beispielen die ich hochgeladen habe.
Dadurch ergibt sich dann eine Überlappung bei den Graphen (z.B. liegt der nächste Graph zum Teil dann über dem Vorherigen usw.)

Hier mal ein Screenshot, damit du siehst was ich meine:


Gibt es eine Möglichkeit, dass das Ende der erstellten Tabelle ODER das Ende des Graphen genommen wird um dann den Abstand zum nächsten Lieferplan zu erstellen (also je nachdem was länger ist)?

Ich hoffe sehr auf deine nochmalige Hilfe :)

Beste Grüße,
Jan

 

Hi Jan,

ersetze diese Zeilen

Code:

            End With
            DoEvents
        End With
        lngZeile = lngEnde
        lngZiel = lngZiel + lngAnzahl + 3
    Next lngZeile
    Application.ScreenUpdating = True
End Sub

durch diese

Code:

            End With
            DoEvents
            If lngAnzahl < 11 Then
                lngZeile = .ChartObjects(.ChartObjects.Count).BottomRightCell.Row + 2
            Else
                lngZeile = lngZeile + Application.CountIf(Columns(1), Cells(lngZeile, 1)) - 1
            End If
            lngZiel = lngZiel + lngAnzahl + 3
        End With
    Next lngZeile
    Application.ScreenUpdating = True
End Sub

Bis später,
Karin