copieren onder shapes

[geep1980]

Ik heb een aantal shapes in sheet1 en een aantal waardes in sheet2
Ik ben opzoek naar een macro die in sheet2 kijkt waar de waarde uit de Shape voorkomt en daarna de waarde uit kolom a en B copieerd onder de shape in sheet1 is dit mogelijk

In het bestand is het nog een keer beschreven.

Is dit mogelijk?Bekijk bijlage Value_onder_shape.xls

 

[LucB]

Dag Geep1980,

Ik heb een poging gedaan met "ApplicationCaller".
Het is niet helemaal gelukt, maar er kijken nog meer mensen naar.

 

[WHER]

Een andere poging. De Shapes worden eerst "op orde" gezet.
Run de macro via Alt-F8 >> macro "tst"

 

[geep1980]

Bekijk bijlage Hulp.zipWher bedankt ik ga kijken of ik het werkend krijg.

LucB ik heb geprobeerd de macro te runnen maar ik krijg een foutmelding op:
Set rng = Sheets(1).Shapes(Application.Caller).TopLeftCell.Offset(6, 0)
The item with the specified name wasn't found.

Ik gebruik excel 2007

bijgaand een bestand van wat ik aan shapes en waardes heb die er onder moeten komen.
In module 1 de macro hoe ik de shapes op het sheet Drawing maak.

 

[cow18]

zie bijgaande code.
Ik weet niet precies wat je wil verzamelen aan gegevens, dus je moet anders maar even met die offsets gaan stoeien.

Sub TekstBijShape()
  Dim shp As Shape, Naam As String, c As Range, Firstaddress As String, Tekst As String, splits As Variant, i As Integer

  For Each shp In Sheets("drawing").Shapes                 'loop alle shapes af
    Naam = shp.TextFrame.Characters.Text                   'wat staat er in die shape
    Tekst = ""                                             'leegmaken variabele om gegevens op te halen
    i = 0
    With Sheets("import_nagios").Columns(1)                'zoek in deze kolom
      Set c = .Find(Naam, Lookat:=xlPart)                  'zoek alle cellen waar gezocht item in staat
      If Not c Is Nothing Then
        Firstaddress = c.Address
        Do
          i = i + 1
          Tekst = Tekst & c.Offset(0, 0).Value & vbLf      'verzamel alle info (ik weet niet precies wat, verander anders die offset)
          Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Firstaddress And i < 3
      End If
    End With
    If Tekst <> "" Then                                    'er zijn gegevens verzameld
      splits = Split(Tekst, vbLf)                          'knip ze in stukjes
      shp.TopLeftCell.Offset(0, 2).Resize(UBound(splits) + 1).Value = WorksheetFunction.Transpose(splits)  'zet die zoveel onder je shape
    End If
  Next
End Sub

 

[geep1980]

cow18 heel erg bedankt.
Hier kan ik zeker wat mee. Inderdaad wat stoeien maar goed dat moet lukken.

mijn dank is groot.

Dit scheelt mij een heleboel bestanden maken.

THANKS