"Data from Picture" button is missing

Warum in die Ferne schweifen, die Lösung ist doch so nah. ;-)

Andreas.

Sub Example_CompareData()

Dim i As Integer, j As Integer

Dim Equal(1 To 2) As Range

Dim Missing(1 To 2) As Range



If MsgBox("This example erases all data in the active sheet! Continue?", _

vbOKCancel + vbDefaultButton2, "Example_CompareData") = vbCancel Then Exit Sub



'Create some example data

Cells.Clear

For i = 0 To 5 Step 5

Range("A1").Offset(0, i).Resize(1, 4) = _

Array("Nr", "HeaderA", "HeaderB", "HeaderC")

For j = 1 To 25 'Increase this number for more rows

Range("A1").Offset(j, i).Resize(1, 4) = _

Array(j, Int(10 * Rnd), Int(10 * Rnd), Int(10 * Rnd))

Next

Next



'Compare the columns which heading is "HeaderA" and "HeaderC"

CompareData _

Intersect(Range("A"), ActiveSheet.UsedRange), Array("HeaderA", "HeaderC"), _

Intersect(Range("F:I"), ActiveSheet.UsedRange), Array("HeaderA", "HeaderC"), _

Equal(1), Equal(2), Missing(1), Missing(2), xlYes



'Color the results: blue = equal data, red = missing data

For i = 1 To 2

If Not Equal(i) Is Nothing Then Equal(i).Font.Color = vbBlue

If Not Missing(i) Is Nothing Then Missing(i).Font.Color = vbRed

Next



'Copy the equal data from first range to column K

Range("A11").Copy Range("K1")

Equal(1).Copy Range("K2")



'Copy the missing data from first range to column P

Range("A11").Copy Range("P1")

Missing(1).Copy Range("P2")

End Sub

Sub CompareData( _

ByVal R1 As Range, ByVal ID1, _

ByVal R2 As Range, ByVal ID2, _

Optional ByRef Equal1 As Range, Optional ByRef Equal2 As Range, _

Optional ByRef Missing1 As Range, Optional ByRef Missing2 As Range, _

Optional ByVal Header As XlYesNoGuess = xlNo, _

Optional ByVal Compare As VbCompareMethod = vbBinaryCompare)

'Compares R1 with R2 by rows

' ID could be a single value or an array of values with:

' a column number: 1 to Columns.Count of R1 or R2

' a column name: "A" to "IV" resp. "XFD" in XL2007 and above

' if Header = xlYes then

' a heading: must be somewhere in the first row

' Returns ranges with all equal and missing cells

Const ErrNum = 1000

Dim Dict(1 To 2) As Object 'Scripting.Dictionary

Dim Data() As Variant

Dim Index() As Long

Dim ThisR As Range, ThisE As Range, ThisM As Range, TempR As Range

Dim ThisID As Variant, Temp As Variant

Dim i As Integer, j As Integer

Dim rw As Long, cl As Long

Dim Key As String

If Header = xlGuess Then

Err.Raise ErrNum, "CompareData", "Header=xlGuess is not supported"

End If



'Step 1: Initialize



For i = 1 To 2

'Get the appropriate variables

If i = 1 Then

Set ThisR = R1

ThisID = ID1

If Not IsArray(ThisID) Then

ReDim ThisID(0 To 0)

ThisID(0) = ID1

End If

Else

Set ThisR = R2

ThisID = ID2

If Not IsArray(ThisID) Then

ReDim ThisID(0 To 0)

ThisID(0) = ID2

End If

End If

If ThisR Is Nothing Then

Err.Raise ErrNum, "CompareData", "R" & i & " is nothing"

End If

If IsMissing(ThisID(0)) Then

Err.Raise ErrNum, "CompareData", "ID" & i & " is missing"

End If

'Read in all data

Data = ThisR.Value2

If Not IsArray(Data) Then

ReDim Data(1 To 1, 1 To 1)

Data(1, 1) = ThisR.Value2

End If

If Header = xlYes And UBound(Data) < 2 Then

Err.Raise ErrNum, "CompareData", "R" & i & ": not enough rows"

End If

'Create the dictionary

Set Dict(i) = CreateObject("Scripting.Dictionary")

If Compare = vbTextCompare Then Dict(i).CompareMode = vbTextCompare

ReDim Index(LBound(ThisID) To UBound(ThisID))

If Header = xlYes Then

'Parse the header

For j = LBound(ThisID) To UBound(ThisID)

For cl = 1 To UBound(Data, 2)

If StrComp(ThisID(j), CStr(Data(1, cl)), Compare) = 0 Then

Index(j) = cl

Exit For

End If

Next

If Index(j) = 0 Then

Err.Raise ErrNum, "CompareData", _

"ID" & i & ": Header " & ThisID(j) & " not found"

End If

Next

Else

'Parse the columns

On Error Resume Next

For j = LBound(ThisID) To UBound(ThisID)

If IsNumeric(ThisID(j)) Then

Index(j) = ThisID(j)

Else

Set TempR = Intersect(ThisR.Parent.Columns(ThisID(j)), ThisR)

If Not TempR Is Nothing Then

Index(j) = TempR.Column - ThisR.Column + 1

End If

End If

If Index(j) < 1 Or Index(j) > UBound(Data, 2) Then

On Error GoTo 0

Err.Raise ErrNum, "CompareData", _

"ID" & i & ": Column " & ThisID(j) & " not inside R" & i

End If

Next

On Error GoTo 0

End If



'Create the dictionary from the data

For rw = IIf(Header = xlYes, 2, 1) To UBound(Data)

Key = CStr(Data(rw, Index(LBound(ThisID))))

For j = LBound(ThisID) + 1 To UBound(ThisID)

Key = Key & vbNullChar & CStr(Data(rw, Index(j)))

Next

'Store the row numbers

If Not Dict(i).Exists(Key) Then

Dict(i).Add Key, Array(rw)

Else

Temp = Dict(i)(Key)

ReDim Preserve Temp(LBound(Temp) To UBound(Temp) + 1)

Temp(UBound(Temp)) = rw

Dict(i)(Key) = Temp

End If

Next

Next



'Step 2: Compare the dictionaries and build the results



For i = 1 To 2

j = i Mod 2 + 1

'Get the appropriate variables

If i = 1 Then

Set ThisR = R1

Set ThisE = Equal1

Set ThisM = Missing1

Else

Set ThisR = R2

Set ThisE = Equal2

Set ThisM = Missing2

End If



'Get the keys and search them in the other dictionary

Data = Dict(i).keys

For rw = LBound(Data) To UBound(Data)

Key = Data(rw)

Temp = Dict(i)(Key)

If Dict(j).Exists(Key) Then

For cl = LBound(Temp) To UBound(Temp)

If ThisE Is Nothing Then

Set ThisE = ThisR.Rows(Temp(cl))

Else

Set ThisE = Union(ThisE, ThisR.Rows(Temp(cl)))

End If

Next

Else

For cl = LBound(Temp) To UBound(Temp)

If ThisM Is Nothing Then

Set ThisM = ThisR.Rows(Temp(cl))

Else

Set ThisM = Union(ThisM, ThisR.Rows(Temp(cl)))

End If

Next

End If

Next



'Set the appropriate variables

If i = 1 Then

Set R1 = ThisR

Set Equal1 = ThisE

Set Missing1 = ThisM

Else

Set R2 = ThisR

Set Equal2 = ThisE

Set Missing2 = ThisM

End If

Next

End Sub

Hallo Pauline,

Vielen Dank für deine Hilfe!



Aber ich habe nicht alles gut geklappt - nur
95%.

Mein Ziel:

ich schreibe ein Buch über Geometrie und muss Zeichnungen
in Text ohne Grenzen einfügen.

Aber alle Zeichnungen haben grauen Grenzen.

Meine Frage: was ich habe nicht richtige gemacht?

(Ich habe Office Professional 2013 (eng.)).

Stage 1.



1. Pic.1->INSERT->Pictures->From File…

…right-click->Size and Position->Text Wrapping->Square->Both Sides.



Pic. 2 - is similar.



Stage 2.



2. Pic.1->PICTURE TOOLS->Picture Styles->Simple Frame, Black-> Picture Border->No Outline.

=================================================

Aber PECH – das Bild hat graue Grenze.



Warum?



Grüß.

Michael

Hallo,

lass mich versuchen dir zu helfen.

Auf der folgenden Website (auf Englisch) findest du ähnliche Diskussion und Lösungsansätze zur Behebung des Problems:

OneDrive icon missing from system tray.

Lass uns wissen, ob dir das geholfen hat.

LG

AEG

It is OK to use the Org Chart Wizard to create the structure of an org chart, then to use External Data to update the data. However, they have conflicting methods of displaying data. In this case, I recommend turning off the Data Graphics by unticking the Data \ Advanced Data Linking \ Advanced Data Graphics dropdown menu before linking the data.
<br />Alternatively, if the shapes have already been linked, you may be able to:
<br />1. Ensure nothing is selected
<br />2. Tick the Data \ Show/Hide \ Data Graphics option to open the panel, then untick any fields for the recordset
<br />Or
<br />1. Select all of the org chart shapes
<br />2. Apply the No Data Graphic option from the Data Graphics by unticking the Data \ Advanced Data Linking \ Advanced Data Graphics dropdown
<br />

Nimm Power Query und importiere die relevanten Daten.
<br />Combine data from multiple data sources (Power Query) - Excel
<br />Andreas.
<br />