2010-12-09 4 views

Antwort

2

Ich schrieb dies vor kurzem. Es könnte für Sie arbeiten. Es versucht, Pivot-Cache- und/oder Abfragetabellendaten für die aktive Arbeitsmappe in die Zwischenablage zu kopieren. Es ist von On Error Resume Next umgeben, so dass, wenn es ein bestimmtes Stück von Daten nicht findet es weiter geht:

Sub Copy_Connection_Info_To_Clipboard() 

Dim ptCache As Excel.PivotCache 
Dim qtQueryTable As Excel.QueryTable 
Dim strPtCacheInfo As String 
Dim strQueryTableInfo As String 
Dim ws As Excel.Worksheet 
Dim strConnectionInfo As String 
Dim doConnectionInfo As DataObject 

On Error Resume Next 
For Each ptCache In ActiveWorkbook.PivotCaches 
    With ptCache 
     strPtCacheInfo = _ 
     strPtCacheInfo _ 
     & "PivotCache #" & "Index: " & .Index & vbCrLf & vbCrLf _ 
         & "SourceDataFile: " & .SourceDataFile & vbCrLf & vbCrLf _ 
         & "CommandText: " & .CommandText & vbCrLf & vbCrLf _ 
         & "SourceConnectionFile: " & .SourceConnectionFile & vbCrLf & vbCrLf _ 
         & "Connection: " & .Connection & vbCrLf & vbCrLf 
    End With 
Next ptCache 
If strPtCacheInfo <> "" Then 
    strPtCacheInfo = "PivotCache Info" & vbCrLf & vbCrLf & strPtCacheInfo 
End If 

For Each ws In ActiveWorkbook.Worksheets 
    If ws.QueryTables.Count > 0 Then 
     strQueryTableInfo = "Worksheet: " & ws.Name & vbCrLf 
     For Each qtQueryTable In ActiveSheet.QueryTables 
      With qtQueryTable 
       strQueryTableInfo = _ 
       strQueryTableInfo _ 
       & "QueryTable Name: " & .Name & vbCrLf & vbCrLf _ 
       & .SourceDataFile & vbCrLf & vbCrLf _ 
       & .CommandText & vbCrLf & vbCrLf _ 
       & .SourceConnectionFile & vbCrLf & vbCrLf _ 
       & .Connection & vbCrLf & vbCrLf 
      End With 
     Next qtQueryTable 
    End If 
Next ws 
If strQueryTableInfo <> "" Then 
    strQueryTableInfo = "Query Table Info" & vbCrLf & strQueryTableInfo 
End If 

strConnectionInfo = strPtCacheInfo & strQueryTableInfo 
If strConnectionInfo <> "" Then 
    Set doConnectionInfo = New DataObject 
    doConnectionInfo.SetText strConnectionInfo 
    doConnectionInfo.PutInClipboard 
End If 

End Sub 
+0

Vielen Dank! es hat funktioniert :) – ichigo

Verwandte Themen