AW: Grafik aus Zahlenreihen erstellen
ChrisL
Hi Simon
Index muss Zahl 1-200 und Daten am richtigen Ort sein (wie in deinem Beispiel) damit es funktioniert.
Gruss
Chris
Sub Simsalabim()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim Diagramm As Chart
Dim iZeile As Long, iSpalte As Integer
Dim LetzteZeile As Long
Application.ScreenUpdating = False
Set WS1 = Worksheets("TabelleDaten") ' <-- Name der Ausgangstabelle
' Tabelle 'Hilfstabelle' erstellen
If WSVorhanden("Hilfstabelle") Then
Set WS2 = Worksheets("Hilfstabelle")
WS2.Rows("2:65536").ClearContents
Else
Set WS2 = Sheets.Add
WS2.Name = "Hilfstabelle"
For iSpalte = 1 To 200
WS2.Cells(1, iSpalte) = "Index " & iSpalte
Next iSpalte
End If
' Daten umsortieren und in Hilfstabelle abfüllen
For iZeile = 1 To WS1.Range("A65536").End(xlUp).Row
WS2.Cells(WS2.Cells(65536, WS1.Cells(iZeile, 1)).End(xlUp).Row + 1, WS1.Cells(iZeile, 1)) = WS1.Cells(iZeile, 2)
Next iZeile
' Überfüssige Spalten löschen
For iSpalte = 200 To 1 Step -1
LetzteZeile = WS2.Cells(65536, iSpalte).End(xlUp).Row
If WS2.Cells(2, iSpalte) = "" Or _
WorksheetFunction.CountIf(WS2.Range(WS2.Cells(LetzteZeile, iSpalte), WS2.Cells(2, iSpalte)), WS2.Cells(2, iSpalte)) = LetzteZeile - 1 Then _
Columns(iSpalte).Delete
Next iSpalte
' Diagramm erzeugen
Set Diagramm = Charts.Add
With Diagramm
.SetSourceData Source:=WS2.UsedRange
.Location Where:=xlLocationAsNewSheet
End With
Application.ScreenUpdating = True
End Sub
Function WSVorhanden(strWS As String) As Boolean
Dim WS As Worksheet
' Funktion zur Prüfung ob Tabelle vorhanden
For Each WS In ActiveWorkbook.Worksheets
If WS.Name = strWS Then
WSVorhanden = True
Exit Function
End If
Next WS
End Function