Geben Sie das Arbeitsblatt zurück, das ein Excel-Diagramm mit VBA referenziert

Question

Ich muss in der Lage sein, das Arbeitsblatt zu identifizieren, aus dem ein Excel-Diagramm (auf einem Arbeitsblatt) seine Daten bezieht. Ich brauche nur das Datenblatt, auf das die Serie 1 verweist. Ich habe angefangen zu versuchen, den Blattnamen von .SeriesCollection (1) .Formula zu extrahieren, aber es wird wirklich komplex. hier ist, was ich so weit gekommen: (! zB Sh'e e $ ,, t 3 $)

Sub GetChartDataSheet() 

Dim DataSheetName As String 
Dim DataSheet As Worksheet 

DataSheetName = ActiveChart.SeriesCollection(1).Formula 

DataSheetName = Left(DataSheetName, InStr(1, DataSheetName, "!$") - 1) 
DataSheetName = WorksheetFunction.Replace(DataSheetName, 1, Len("=series("), "") 
If Left(DataSheetName, 1) = "'" And Right(DataSheetName, 1) = "'" Then DataSheetName = Mid(DataSheetName, 2, Len(DataSheetName) - 2) 
DataSheetName = Replace(DataSheetName, "''", "'") 

Set DataSheet = Sheets(DataSheetName)  

End Sub 

dies in vielen Fällen funktioniert, aber wenn meine Nutzer haben eine seltsame Arbeitsblatt-Namen es schlägt fehl. das gleiche gilt, wenn Serie 1 wurde benannt (zB .SeriesCollection(1).Formula = "=SERIES(**"Hell,o !"**,'Sh''e e$,,t!3!$'!$B$2:$B$18,'Sh''e e$,,t!3!$'!$C$2:$C$18,1)".

Gibt es eine einfache Möglichkeit, dies zu lösen?

Answer 1

Ich dachte, das leicht gefallen ist, stellt sich heraus, es ist nicht. Einer der Fälle, in denen Excel hat . die Informationen, aber es wird nicht umsonst weggeben ich mit einer Funktion wie diese am Ende - vielleicht hilft:

Function getSheetNameOfSeries(s As Series) As String 

Dim f As String, i As Integer 
Dim withQuotes As Boolean 

' Skip leading comma if not all parts of series is filled. Check if sheetname is in single quotes 
For i = 9 To Len(s.Formula) 
    If Mid(s.Formula, i, 1) <> "," Then 
     If Mid(s.Formula, i, 1) = "'" Then 
      withQuotes = True 
      f = Mid(s.Formula, i + 1) 
     Else 
      withQuotes = False 
      f = Mid(s.Formula, i) 
     End If 
     Exit For 
    End If 
Next i 

' "f" now contains a part of the formula with the sheetname as start 
' now we search to the end of the sheet name. 
' If name is in quotes, we are looking for the "closing" quote 
' If not in quotes, we are looking for "!" 
i = 1 
Do While True 

    If withQuotes Then 
     ' Sheet name is in quotes, found closes quote --> we're done 
     ' (but if next char is also a quote, we have the case the the sheet names contains a quote, so we have to continue working) 
     If Mid(f, i, 1) = "'" Then 
      If Mid(f, i + 1, 1) <> "'" Then 
       getSheetNameOfSeries = Mid(f, 1, i - 1) 
       Exit Do 
      Else 
       i = i + 1  ' Skip 2nd quote 
      End If 
     End If 
    Else 
     ' Sheet name is quite normal, so "!" will indicate the end of sheetname 
     If Mid(f, i, 1) = "!" Then 
      getSheetNameOfSeries = Mid(f, 1, i - 1) 
      Exit Do 
     End If 
    End If 

    i = i + 1 
Loop 

getSheetNameOfSeries = Replace(getSheetNameOfSeries, "''", "'") 

End Function 

Answer 2

Sie die Find Funktion können für die Werte von SeriesCollection(1) aussehen

In. das Arbeitsblatt, das die Daten von SeriesCollection(1) enthält, können Sie alle Werte in diesem Array finden.

Weitere Erläuterungen im folgenden Code.

-Code

Option Explicit 

Sub GetChartDataSheet() 

Dim DataSheetName As String 
Dim DataSheet As Worksheet 
Dim ws As Worksheet 
Dim ValuesArr As Variant, Val As Variant 
Dim FindRng As Range 
Dim ShtMatch As Boolean 

Dim ChtObj As ChartObject 
Dim Ser As Series 

' if you want to use ActiveChart 
Set ChtObj = ActiveChart.Parent 

Set Ser = ChtObj.Chart.SeriesCollection(1) 
ValuesArr = Ser.Values ' get the values of the Series Collection inside an array 

' use Find to get the Sheet's origin 
For Each ws In ThisWorkbook.Sheets 
    With ws 
     ShtMatch = True 
     For Each Val In ValuesArr ' loop through all values in array 
      Set FindRng = .Cells.Find(what:=Val) ' you need to find each value in the worksheet that SeriesCollection data is tied to 
      If FindRng Is Nothing Then 
       ShtMatch = False 
       Exit For 
      End If 
      Set FindRng = Nothing ' reset 
     Next Val 

     If ShtMatch = True Then 
      Set DataSheet = ws 
      Exit For 
     End If 
    End With 
Next ws 
DataSheetName = DataSheet.Name 

End Sub