Zu Datensatz ein Diagramm erstellen

Hallo zusammen,

ich habe ein Makro geschrieben welches mir Daten zusammenfügt und davon statistische Werte berechnet welche im Blatt "Auswertung" angezeigt werden.

Nun möchte der Mitarbeiter aber noch Diagramme zu diesen Daten haben (ebenfalls im Blatt Auswertung)

Daten sind im Sheet "Rohdaten_gesamt" jede Spalte hat in Zeile 1 den Titel/Bezeichnung und von dort nach unten die Rohdaten (nicht immer gleiche Bereich der Spalte - einmal sind es 701 Zeile, beim nächsten mal vllt 1078)

Ein Diagramm für "Dicke" dieser Wert steht in Spalte C
Ein Diagramm für "Auslenkung" dieser Wert steht in Spalte D
Ein Diagramm für "RIS" dieser Wert steht in Spalte I
Ein Diagramm für "C - Klein" dieser Wert steht in Spalte J
Ein Diagramm für "Frequenz" dieser Wert steht in Spalte L

Anbei noch eine BEispiel Datei und mein Code:
https://www.herber.de/bbs/user/164234.xlsm

Option Explicit

Dim wsOutput As Worksheet

Dim sql_cmd As String

Dim sql_result As Variant

Dim metis As Object

Sub Messung()



'Deaktivieren von Bildschirm Updates während Lauf des Makros

Application.ScreenUpdating = False

'Deaktivieren von Bildschirm Alarmen während Lauf des Makros

Application.DisplayAlerts = False



Sheets("Output_SAP").Visible = True



'deklarieren von Variablen

Dim a As Integer

Dim wsh As Worksheet

Dim ws As Worksheet

Dim DateiPfad As String

Dim LosnummerFuerDateien As String

Dim Lrow1 As Integer

Dim Current As Worksheet

Dim shtCount As Integer

Dim UpperControlLimitDicke As Double

Dim LowerControlLimitDicke As Double

Dim UpperControlLimitAuslenkung As Double

Dim LowerControlLimitAuslenkung As Double

Dim UpperControlLimitRIS As Double

Dim LowerControlLimitRIS As Double

Dim UpperControlLimitFrequenz As Double

Dim LowerControlLimitFrequenz As Double

Dim AnzahlVonMessungen As Integer

Dim StueckzahlSAP As Integer

Dim Lrow2 As Integer

Dim strSkip As String



Set metis = Ora_connect("METIS", "auskunft", "auskunft")



Application.StatusBar = "fetching data"



'Festlegen des Speicherortes

DateiPfad = Sheets("Start").Range("A11").Value

'gewünschten Losnummer übergabe

LosnummerFuerDateien = Sheets("Start").Range("A13").Value

'set to current worksheet name

Set ws = ActiveWorkbook.Sheets("Rohdaten_gesamt")

DateiPfad = DateiPfad & "\" & LosnummerFuerDateien & "*.*"



'nicht benötigte tabellen löschen

    strSkip = "Start, Rohdaten_gesamt, Auswertung, Output_SAP"

    For Each wsh In Worksheets

        If InStr(strSkip, wsh.Name) = 0 Then

            wsh.Delete

        End If

    Next

    

    'Daten von vorherigen Durchlauf löschen

    Worksheets("Rohdaten_gesamt").Rows(2 & ":" & Worksheets("Rohdaten_gesamt").Rows.Count).Delete

    'Diagramme löschen

    With Sheets("Auswertung")

        For a = .ChartObjects.Count To 1 Step -1

            .ChartObjects(a).Delete

        Next a

    End With

    

'Datei auswählen und importieren

    Dim fd As FileDialog, Lrow As Long, vSelectedItem As Variant, srcWB As Workbook, desWB As Workbook

    Set desWB = ThisWorkbook

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd

        .AllowMultiSelect = True

        .InitialFileName = DateiPfad

        .Filters.Clear

        '.Filters.Add "Objects", (LosnummerFuerDateien.csv)

        If .Show = -1 Then

            For Each vSelectedItem In .SelectedItems

                'csv files nach semikolon trennen

                Workbooks.OpenText Filename:=vSelectedItem _

                , Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _

                xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=True, _

                Comma:=False, Space:=False, Other:=False, OtherChar:=";", FieldInfo:= _

                Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7 _

                , 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array _

                (14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), _

                Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array( _

                 27, 1), Array(28, 1)), TrailingMinusNumbers:=True

                If Left(ActiveWorkbook.Name, 9) = LosnummerFuerDateien Then

                    Set srcWB = ActiveWorkbook

                    ActiveSheet.Name = ActiveWorkbook.Name

                    Sheets(1).Copy After:=desWB.Sheets(desWB.Sheets.Count)

                    srcWB.Close

                Else

                    ActiveWorkbook.Close

                    GoTo Iteration

                End If

Iteration:

            Next

        End If

    End With



    'Anzahl der Sheets zählen

    shtCount = Sheets.Count

    If shtCount = 3 Then

        GoTo Iteration1

    Else

        For Each Current In ThisWorkbook.Worksheets

            If Current.Name = "Start" Or Current.Name = "Rohdaten_gesamt" Or Current.Name = "Auswertung" Or Current.Name = "Output_SAP" Then

                GoTo Iteration2

            Else

                Current.Activate

                Range("A15").Select

                LowerControlLimitDicke = Right(ActiveCell.Value, 3)

                ActiveCell.Offset(1, 0).Select

                UpperControlLimitDicke = Right(ActiveCell.Value, 3)

                Range("A52").Select

                LowerControlLimitAuslenkung = Right(ActiveCell.Value, 3)

                ActiveCell.Offset(1, 0).Select

                UpperControlLimitAuslenkung = Right(ActiveCell.Value, 3)

                Range("A82").Select

                UpperControlLimitFrequenz = Right(ActiveCell.Value, 5)

                ActiveCell.Offset(1, 0).Select

                LowerControlLimitFrequenz = Right(ActiveCell.Value, 5)

                Lrow2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

                Range("A92:AB" & Lrow2).Select

                Selection.Copy

                Sheets("Rohdaten_gesamt").Activate

                Lrow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

                Cells(Lrow1 + 1, 1).Select

                ActiveSheet.Paste

            End If

Iteration2:

        Next Current

    End If





    sql_cmd = "SELECT a.RMENGE, a.TEXT FROM vs.KOPFLL k INNER JOIN vs.APOSLL a ON (k.LOSNR = a.LOSNR) WHERE a.TEXT = 'POLEN / MESSEN AUSLENKUNG' And k.LOSNR = '" & LosnummerFuerDateien & "'"

    sql_result = sql_request(metis, sql_cmd)

    Set wsOutput = ThisWorkbook.Sheets("Output_SAP")

    wsOutput.UsedRange.ClearContents

    Call sql2table(sql_result, ThisWorkbook.Name, wsOutput.Name, 1, 2, 1, False, True)



    Worksheets("Rohdaten_gesamt").Range("A1:AB856").AutoFilter Field:=28, Criteria1:="Good"



    Sheets("Auswertung").Activate

    Range("B3").Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[1])"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[2])"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[7])"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[8])"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[10])"

    ActiveCell.Offset(-4, 1).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C)"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[1])"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[6])"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[7])"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[9])"

    ActiveCell.Offset(-4, 2).Select

    ActiveCell.Value = UpperControlLimitDicke

    ActiveCell.Offset(0, 1).Select

    ActiveCell.Value = LowerControlLimitDicke

    ActiveCell.Offset(1, -1).Select

    ActiveCell.Value = UpperControlLimitAuslenkung

    ActiveCell.Offset(0, 1).Select

    ActiveCell.Value = LowerControlLimitAuslenkung

    ActiveCell.Offset(1, 0).Select

    ActiveCell.Value = "75"

    ActiveCell.Offset(0, -1).Select

    ActiveCell.Value = "139"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.Value = "3"

    ActiveCell.Offset(0, 1).Select

    ActiveCell.Value = "2"

    ActiveCell.Offset(1, 0).Select

    ActiveCell.Value = LowerControlLimitFrequenz

    ActiveCell.Offset(0, -1).Select

    ActiveCell.Value = UpperControlLimitFrequenz

    

    Sheets("Rohdaten_gesamt").Activate

    Lrow2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    AnzahlVonMessungen = WorksheetFunction.Subtotal(3, Range("A2:A" & Lrow2))

    Columns("A:AB").EntireColumn.AutoFit

    Columns("A:AB").Select

    With Selection

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlBottom

    End With

    Sheets("Output_SAP").Activate

    StueckzahlSAP = Range("A2").Value

    Sheets("Auswertung").Activate

    Range("I3").Select

    ActiveCell.Value = AnzahlVonMessungen

    ActiveCell.Offset(0, -1).Select

    ActiveCell.Value = StueckzahlSAP

    If Range("H3").Value > Range("I3").Value Then

        Range("H3:I3").Select

        Selection.Interior.ColorIndex = 3

    Else

        Range("H3:I3").Select

        Selection.Interior.ColorIndex = 4

    End If



    Call Create_HistogramDicke

    Call Create_HistogramAuslenkung

    Call Create_HistogramRIS

    Call Create_HistogramCKlein

    Call Create_HistogramFrequenz

    

    Sheets("Output_SAP").Select

    ActiveWindow.SelectedSheets.Visible = False

    Sheets("Auswertung").Activate

Iteration1:

End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Sub Create_HistogramDicke() Dim Lrow3 As Integer Dim nw_chart As Chart Dim desti_sht As Worksheet Dim rngBereich As Range Set desti_sht = Worksheets("Auswertung") With Worksheets("Rohdaten_gesamt") Lrow3 = .Cells(Rows.Count, 1).End(xlUp).Row Set rngBereich = Union(.Range(.Cells(1, 1), .Cells(Lrow3, 1)), .Range(.Cells(1, 3), .Cells(Lrow3, 3))) End With Set nw_chart = desti_sht.ChartObjects.Add(0, 0, 0, 0).Chart With nw_chart .ChartType = xlColumnClustered .SetSourceData Source:=rngBereich .HasTitle = True .Axes(xlCategory, xlPrimary).HasTitle = True .Axes(xlCategory, xlPrimary).AxisTitle.Text = "Time" .ChartTitle.Characters.Text = "Dicke [mm]" With .Parent .Top = Range("B13").Top .Left = Range("B13").Left .Height = Range("B13:B25").Height .Width = Range("B13:D13").Width End With End With End Sub

Beliebteste Forumthreads (12 Monate)

Zu Datensatz ein Diagramm erstellen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread