Macro (sätta funktion =Blad1!A9) till flera celler

[Templo]

Hej!

 

Jag är nybörjare här och vill tacka för alla bra tips

som jag har hittat här. Nu till mitt problem.

 

Jag har ett blad med 8 kolumner och många rader

(kan variera mellan 30 och 200 i olika filer) och

ett varierande antal blad (beroende på hur många rader jag har på första bladet)

som ska spegla inehället från olika delar av första bladet d.v.s.

området A9:H20 ska speglas på bladet 2 A21:H27 blad 3

A28:H41 blad 4 ............

 

Jag kör med =Blad1!A9 som jag sen fyller serie till H20 och

så vidare med alla andra områden till olika blad.

 

Kan man göra ett makro så att man markerar område på

blad 2 (eller nåt av dem andra bladen), går till blad 1

och markerar området som man vil kopiera till blad 2 och

få funktion =Blad1!A.. ifylld i alla celler.

 

Kör realativt för listan uppdaters då och då och

då måste nummerering fytta neråt automatiskt.

 

Tack på förhand!

 

 

[Monshi]

Det är lite omständligare än man önskar/tror att kopiera länkar. Men svårt är det inte.

 

Sub Test()
   Dim rnSource As Range
   Dim rnTarget As Range
   Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)
   Set rnTarget = Application.InputBox( _
   prompt:="Markera den cell du vill att klista in till" & vbNewLine _
   & "Notera att ett område lika stort som det kopierade " & rnSource.Rows.Count & _
   "x" & rnSource.Columns.Count & " kommer skrivas över", Type:=8)
   rnSource.Copy
   rnTarget.Parent.Activate
   rnTarget.Select

   rnTarget.Parent.Paste Link:=True
   rnTarget.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
       SkipBlanks:=False, Transpose:=False
End Sub

 

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

Vet inte om jag är mer imponerad av lösningen eller

den korta svarstiden?!

 

Stort TACK!

 

[Templo]

Jag försökte modifiera macrot (som ett nytt) så att det läser bara

en cell på det aktiva bladet och klistrar in t.ex =Blad1!A9 i shape

men det gick inte.

 

Går det överhuvudtaget?

 

[Monshi]

Vad menar du? Klistra in i en shape?

 

Du kanske menar att du vill ha en bildkopia av blad1 på blad2, det är en ganska trevlig lösning för den delen.

 

Vi börjar enkelt, några celler på blad1 på blad2 manuellt:

1: Kopiera cellerna som vanligt

2: Byt till blad2

3: Håll ned SHIFT och öppna menyn Redigera, välj det nu synliga menyvalet Klistra in bildlänk.

 

Bäst ser detta ut om inte stödlinjerna visar på blad2, de kan du stänga av i Verktyg -> Alternativ

 

Nu till en försmak av det avancerade.

Gå tillbaka till blad1 och infoga en rad inom det område du kopierade. När du återvänder till blad2 ser du att den länkade bilden även den har vuxit!

 

Till det avancerade, steg1

Gå tillbaka till blad1, markera området du kopierat och ge det ett nanm, du kan skriva in det i namnlisten eller via menyn Infoga->Namn->Definiera.

Tillbaka till blad2, klicka bilden och ange i adressfältet namnet du nyss skapade.

 

Steg2

Nu antar jag att dina rådata finns på Blad1, cell A1, fem kolumner bortåt och nedåt obrutet i A-kolumnen, dvs inga tomma celler inom dataområdet.

Öppna menyn Infoga->Namn->Definiera

Klicka på namnet du nyss skapade och skriv in följande formel:

=FÖRSKJUTNING(Blad1!$A$1;0;0;ANTALV(Blad1!$A:$A);5)

(5 kan givetvis bytas ut mot ANTALV(Blad1!$1:$1) för att räkna antalet kolumner istället)

 

Skriv sedan in ett värde sist i A-kolumnen och gå till blad2 och se vad som hänt...

 

Hänger du med?

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

Tack för denna nya funktion, kan komma att behövas men det jag menade

var exact det som du undrade i början av posten, att kopiera funktion

=A1....... till shape istället för att skriva för hand alltså

klicka på cellen, kopiera funtion och klistra in i shape.

 

Det handlar om data som finns på blad 1 som kopieras med ditt första macro (fungerar utmärkt:-)) till övriga blad. Övriga blad har förutom kopierade data bilder med punkter (shapes) som pekar på

ett visst område på bilderna och som ska överensstämma med

med ett nummer i kolumn A.

 

Hoppas att förklaringen blev bättre än första gången!

 

[Monshi]

Ah, du vill ta med en bild i kopieringen. Varför sade du inte det?

 

Ett sätt att göra det är följande:

Sub Test()
Dim rnSource As Range
Dim rnTarget As Range
Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)
Set rnTarget = Application.InputBox( _
prompt:="Markera den cell du vill att klista in till" & vbNewLine _
& "Notera att ett område lika stort som det kopierade " & rnSource.Rows.Count & _
"x" & rnSource.Columns.Count & " kommer skrivas över", Type:=8)
rnSource.Copy
rnTarget.Parent.Activate
rnTarget.Select
rnTarget.Parent.Paste Link:=True
rnTarget.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Dim myShape As Shape
For Each myShape In rnSource.Parent.Shapes
   If Not Application.Intersect(myShape.TopLeftCell, rnSource) Is Nothing Then
       myShape.Copy
       rnTarget.Parent.Paste
       rnTarget.Parent.Shapes(rnTarget.Parent.Shapes.Count).Top = _
               rnTarget.Cells(1, 1).Top + (myShape.Top - rnSource.Cells(1, 1).Top)
       rnTarget.Parent.Shapes(rnTarget.Parent.Shapes.Count).Left = _
               rnTarget.Cells(1, 1).Left + (myShape.Left - rnSource.Cells(1, 1).Left)
   End If
Next myShape


End Sub

 

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

Monshi jag uppskatar verkligen tiden som du lägger ner här

samtidigt som jag beklagar att jag stjäler din tid med felaktig

förklaring. Det senaste macro kommer jag 100% att ha användning

till (och andra tror jag) men det var inte det jag ville.

 

Det handlar helt enkelt om ett nytt macro som ska kopiera

funktion "=A:1" eller nån annan cells "=" funktion till valfria

shapes (som jag har på de övriga bladen).

Alltså nästan likadant macro som första med skilnaden

att målet är shape. Om innehållet i en cell är T.ex.32 ska

det visas 32 även i shape. Ändras cellinehållet till 33 ska

även ändras i shape till 33.

 

Macro = Markera Cell (kopiera funktion)- Markera Shape (klistra in

funktion).

 

 

Tackar igen!

 

 

[inlägget ändrat 2007-11-09 13:32:50 av Templo]

[inlägget ändrat 2007-11-09 13:54:41 av Templo]

[Monshi]

Jag är inte riktigt med vad du menar.

 

Ett diagram är en "shape" exempelvis. Så som jag förstått det vill du ta med de bilder/shapes som finns inom det område du markerar för att kopiera. Vid kopieringen vill du ha en kopia av området med länk tillbaka till cellerna du kopierade.

 

Fast vill du ha med formlerna? Varför måste jag nog då fråga?

Fast det är inget svårt, bara ändra lite i koden ovan så att formlerna kopieras in:

rnTarget.PasteSpecial Paste:=xlPasteFormulas

 

Fast notera att det är EXAKT formeln som kopieras. Om den refererar till cell på bladet fortsätter den referera inom bladet fast nu det nya dit den kopiearades.

Vill du kopiera allt, ja då är den ännu enklare

rnSource.Copy destination:= rnTarget

 

dvs den raden är ALLT du behöver bortsett från dialogerna.

 

Nä du - vad är det du egentligen försöker göra och varför? Förklara varför du försöker göra just detta, kanske jag kommer upp med annan lösning utan denna makro-problematik.

 

Kanske en skärmdump på vad du har och vad du vill ha?

 

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

Hej igen!

 

Synd att man inte kan bifoga Excel filer

så jag måste bifoga tre bilder.

 

[bild bifogad 2007-11-09 15:11:31 av Templo]

[bild bifogad 2007-11-09 15:12:12 av Templo]

[Templo]

Nästa bild!

 

[bild bifogad 2007-11-09 15:12:53 av Templo]

[Templo]

Och sista!

 

Och uppdatering som jag skriver om på sista bilden

fixar jag med första macrot. Det som står på Bild 2 är problemet.

 

[bild bifogad 2007-11-09 15:14:04 av Templo]

[inlägget ändrat 2007-11-09 15:16:52 av Templo]

[Monshi]

Okej, inte helt med ändå, tyvärr.

 

Jag spånar lite

I grunden har du en bild och på denna lägger du ett antal etiketter/textrutor. Vad som står i dessa vill du enkelt kunna reglera antar jag.

 

Eller är själva problemet sättet man anger länken i textrutan?

 

Sub test2()
   Dim rnSource As Range
   Dim myShape As Variant
   Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)
   If rnSource Is nothingn Then Exit Sub
   Set myShape = rnSource.Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, rnSource.Left + 10, rnSource.Top, _
       rnSource.Width, rnSource.Height)
   myShape.Select
   Selection.Formula = rnSource.Address
End Sub

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

""Eller är själva problemet sättet man anger länken i textrutan?""

 

Det är det som är problemet, jag vill helst undvika att skriva

länken för hand (räcker att jag måste infoga rektangel och pil varje gång).

 

Helt enkelt skulle det vara så här:

 

Macro = Markera Cell (kopiera funktion)- Markera Rektangel (klistra in

funktion).

 

Senaste koden fastnar på dem röda bokstäverna:

 

Sub test2()

Dim rnSource As Range

Dim myShape As Variant

Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)

If rnSource Is nothingn Then Exit Sub

Set myShape = rnSource.Parent.Shapes.AddTextbox(msoTextOrientationHorizont

al, rnSource.Left + 10, rnSource.Top, _

rnSource.Width, rnSource.Height)

myShape.Select

Selection.Formula = rnSource.Address

End Sub

 

 

och meddelande :

Kompileringsfel=Syntaxfel

 

 

 

[Templo]

Efter att "rnSource.Parent.Shapes.AddTextbox(msoTextOrientationHorizont

al, rnSource.Left + 10, rnSource.Top, _" ändrats till en rad fastnade det

på "If rnSource Is nothingn Then Exit Sub". Jag raderade det och då gick

det vägen och en rektangel med funtion kom fram.

 

Underbart, men kan man få relativ istället för absolut referens?

Och om jag ska vara jobbig (ännu mer) kan man få formatering

med, typ röda kanter och att rektangelsstorlek anpassar sig till text?

 

[Templo]

Löste själv Relativ/Absolute med:

"Selection.Formula = rnSource.Address(RowRelative, ColumnRelative)"

 

Bara formatering och av textrutan och eventualt infogade av pil kvar.

 

[Monshi]

Stavfel av mig

 

If rnSource Is nothingn Then Exit Sub

Bort med feta bokstaven n

Samt kompileringsfel på röda raderna troligen problem med radbrytningarna Eforum infogat

 

Formatering - spela in makro där du formaterar som du önskar. Anpassa koden och stoppa in den i modellen du har fått av mig.

 

Så nu är vi på rätt spår?

 

Tyvärr kan vi inte klicka och peka i en bild och på så sätt få fram var du vill ha textboxen eller eventuella pilar. En cell går däremot bra.

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

Helt rätt spår! Att kunna peka på bilden är lyx, det räcker med aktiv cell.

 

Jag har fått till det med formatering och kan få connector med

men kan inte koppla connector till shape i ett och samma macro.

 

Kompletterar jag ditt macro med shape-formatering och bara infoga connector

fungerar det men när jag försöker koppla connector till shape, fungerar det inte.

 

Det är de röda raderna som jag inte får att fungera.

Har försökt att ändra till myShape men macrot vägrar.

Hur kan jag koppla connector direkt till den shape som macro skapar?

 

Här kommer koden:

[log]

Sub test2()

 

Dim rnSource As Range

Dim myShape As Variant

Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)

If rnSource Is Nothing Then Exit Sub

Set myShape = rnSource.Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, rnSource.Left + 10, rnSource.Top, _

rnSource.Width, rnSource.Height)

myShape.Select

Selection.Formula = rnSource.Address(RowRelative, ColumnRelative)

With Selection.Font

.Name = "Arial"

.FontStyle = "Normal"

.Size = 10

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ReadingOrder = xlContext

.Orientation = xlHorizontal

.AutoSize = True

End With

Selection.ShapeRange.Fill.Visible = msoTrue

Selection.ShapeRange.Fill.Solid

Selection.ShapeRange.Fill.ForeColor.SchemeColor = 65

Selection.ShapeRange.Fill.Transparency = 0#

Selection.ShapeRange.Line.Weight = 1.5

Selection.ShapeRange.Line.DashStyle = msoLineSolid

Selection.ShapeRange.Line.Style = msoLineSingle

Selection.ShapeRange.Line.Transparency = 0#

Selection.ShapeRange.Line.Visible = msoTrue

Selection.ShapeRange.Line.ForeColor.SchemeColor = 10

Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)

With Selection

.Placement = xlFreeFloating

.PrintObject = True

End With

ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 27#, 154.5, 182.25, _

19.5).Select

Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle

Selection.ShapeRange.Flip msoFlipVertical

Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes( _

"Text Box 20"), 4

Selection.ShapeRange.Fill.Transparency = 0#

Selection.ShapeRange.Line.Weight = 1#

Selection.ShapeRange.Line.DashStyle = msoLineSolid

Selection.ShapeRange.ConnectorFormat.Type = msoConnectorStraight

Selection.ShapeRange.Line.Style = msoLineSingle

Selection.ShapeRange.Line.Transparency = 0#

Selection.ShapeRange.Line.Visible = msoTrue

Selection.ShapeRange.Line.ForeColor.SchemeColor = 10

Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)

Selection.ShapeRange.Line.BeginArrowheadLength = msoArrowheadLengthMedium

Selection.ShapeRange.Line.BeginArrowheadWidth = msoArrowheadWidthMedium

Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone

Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium

Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium

Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle

With Selection

.Placement = xlFreeFloating

.PrintObject = True

End With

End Sub

[/log]

 

----------------------------------------------------------

Redigerat av moderator - mycket kod - en log-tag tack

(tittar på ditt problem under morgindagen)

----------------------------------------------------------

 

[inlägget ändrat 2007-11-09 23:23:28 av Monshi]

[Monshi]

Okej, nu har jag snyggat till din kod lite. Bort med majoriteten av Select-satserna men helt har jag inte lyckats bli av med dem. Ärligt talat verkar de textrutor som man kan lägga till ha en salig blandning av möjliga inställningar. En del kan ges direkt till textbox-objektet, en del enbart till Selection-objektet och en del till Selection.ShapeRange.

 

Intressant blandning. Koden blir därmed inte så vacker, inte i detta försök ivartfall. Kanske det går att göra på annat sätt? Vad jag främst vill bli av med är dess två rader:

myShape1.Select

Set myShape1 = Selection

Ser onödig ut men är av vikt för att resten av koden ska fungera. Borde inte behövas tycker jag. Men men, det fungerar:

[log]Sub AddBoxWithLink(rnSource As Range, rnTarget As Range)

Dim myShape1 As Variant

Set myShape1 = rnSource.Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, rnTarget.Left, rnTarget.Top, _

rnSource.Width, rnSource.Height)

 

myShape1.Select

 

Set myShape1 = Selection

With myShape1

With .Font

.Name = "Arial"

.FontStyle = "Normal"

.Size = 10

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

 

With .ShapeRange

With .Fill

.Visible = msoTrue

.Solid

.ForeColor.SchemeColor = 65

.Transparency = 0#

End With

With .Line

.Weight = 1.5

.DashStyle = msoLineSolid

.Style = msoLineSingle

.Transparency = 0#

.Visible = msoTrue

.ForeColor.SchemeColor = 10

.BackColor.RGB = RGB(255, 255, 255)

End With

End With

.Formula = rnSource.Address()

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ReadingOrder = xlContext

.Orientation = xlHorizontal

.AutoSize = True

.Placement = xlFreeFloating

.PrintObject = True

End With

 

Dim myShape2 As Variant

Set myShape2 = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 27#, 154.5, 182.25, _

19.5)

myShape2.Select

Set myShape2 = Selection

With myShape2

With .ShapeRange

.Flip msoFlipVertical

.ConnectorFormat.BeginConnect ActiveSheet.Shapes( _

myShape1.Name), 4

.ConnectorFormat.Type = msoConnectorStraight

.Fill.Transparency = 0#

With .Line

.EndArrowheadStyle = msoArrowheadTriangle

.Weight = 1#

.DashStyle = msoLineSolid

 

.Style = msoLineSingle

.Transparency = 0#

.Visible = msoTrue

.ForeColor.SchemeColor = 10

.BackColor.RGB = RGB(255, 255, 255)

.BeginArrowheadLength = msoArrowheadLengthMedium

.BeginArrowheadWidth = msoArrowheadWidthMedium

.BeginArrowheadStyle = msoArrowheadNone

.EndArrowheadLength = msoArrowheadLengthMedium

.EndArrowheadWidth = msoArrowheadWidthMedium

.EndArrowheadStyle = msoArrowheadTriangle

End With

End With

.Placement = xlFreeFloating

.PrintObject = True

End With

' om du vill gruppera dem

' ActiveSheet.Shapes.Range(Array(myShape1.Name, myShape2.Name)).Group

 

End Sub[/log]

Funktionen tar två områden som anrop, exempelvis denna lilla kodsnutt kan fungera:

Dim rnSource As Range
Dim rnTarget As Range
On Error Resume Next
Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)
If rnSource Is Nothing Then Exit Sub

Set rnTarget = rnSource.Offset(0, 2)
On Error GoTo 0
AddBoxWithLink rnSource, rnTarget

 

Börjar i närma oss målet nu?

 

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

"Börjar vi närma oss målet nu?"

 

He, he, mer och mer! Underbart! Kommer att spara

en jäkla massa tid. Vill bara försäkra mig att jag har

ändrat rätt och här kommer det:

 

Sub AddBoxWithLink()

Dim rnSource As Range

Dim rnTarget As Range

On Error Resume Next

Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)

If rnSource Is Nothing Then Exit Sub

 

Set rnTarget = rnSource.Offset(0, 2)

On Error GoTo 0

Set myShape1 = rnSource.Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, rnTarget.Left, rnTarget.Top, _

rnSource.Width, rnSource.Height)

 

från början fram till myShape1.Select.

 

Dim myShape1 As Variant är borta från

myShape1 men kvar under myShape2

och det ska väl vara så? Det fungerar ju!

 

[Monshi]

VBA handlar variabler riktigt dumt som standard. Som standar behöver man inte deklarera variablerna innan man använder dem.

 

Som första rad i alla modul bör följande rad stå:

Option Explicit

Skriv in för hand eller öppna VBA-editor menyn Verktyg - >alternativ, kryssa för "Variabler måste deklareras"

 

Annars är min rekommendation att du delar på koden så att anropar funktionen jag skapat med den extra kod-klumpen som i sin tur kanske startas av en knapp...

Då skulle man kunna tänka sig att man skriver:

 

Sub BoxGetter()
Dim rnSource As Range
Dim rnTarget As Range
On Error Resume Next
set rnSource = range("A1")
While Not rnSource is Nothing
Set rnSource = Application.InputBox(prompt:="Markera de celler du vill kopiera", Type:=8)
If rnSource Is Nothing Then Exit Sub

Set rnTarget = rnSource.Offset(0, 2)
On Error GoTo 0
AddBoxWithLink rnTarget, rnSource
Wend
End Sub

 

Samt att man kanske frågar efter målcellen också och anpassar koden så att pilen alltid pekar åt samma håll och inte mot en specifik punkt. Eller kanske man ska fråga även efter cell/vart den ska peka?

 

Allt går.

 

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

Nu hänger jag inte med för det här är mycket mer än mina

begränsade kunskaper i VBA klarar och koden blir längre och längre!

 

Får gäster snart, måste fixa lite grejer men återkommer (ska försöka

klura ut var jag palcerar de nya raderna som du skrev.

 

P.S. Det med att pilen alltid pekar åt samma hål

och har samma längd istället för att peka på nån cell låter

fint särskilt med tanke på att pilen senare ändå hamnar på en bild och

man kan inte peka på nån cell.

Men det ska jag inte belasta dig med det utan ska försöka klara själv

 

 

P.S.S. Kan du rekommendera nån bra bok om VBA

som täcker nybörjare - medel nivå?

Helst på svenska!

 

[inlägget ändrat 2007-11-10 18:22:07 av Templo]

[inlägget ändrat 2007-11-10 18:22:46 av Templo]

[inlägget ändrat 2007-11-10 18:25:38 av Templo]

[Monshi]

Bok, nej, men XLDennis sidor, VBA-hjälpen samt Google är en mycket bra grund.

http://www.xldennis.se

 

Det med riktningen på pilen får du fixa själv

Ledrtrådarna jag kan ge är att du vet var boxen finns, hur stor den är. Då är det bara att räkna ut vart pilen ska peka relativt dessa värden.

Inte så svårt...

 

Kanske för att förtydliga koden - döp om myShape1 till myTextBox samt myShape2 till myLine eller liknande.

 

 

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[Templo]

Lite pinsamt att skriva det här men så är det:

kan inte använda connectors för att dem fastnar antigen

på bildens låspunkter eller med "Alt" på celler.

Omöjligt att peka på en exakt punkt på bilder. :-(

 

Tänkte byta ut connector med "msoShapeLineCallout2"

för att med det, kan man peka var som helst på bilder

men klarar inte att fixa till koden. Tips?

 

[Monshi]

Kanske

 

[log]Sub AddBox(rnSource As Range, rnTarget As Range)

Dim myBox As Variant

ActiveSheet.Shapes.AddShape(Type:=msoShapeLineCallout2, Left:=rnTarget.Left, _

Top:=rnTarget.Top, Width:=72#, Height:=48#).Select

Set myBox = Selection

With myBox

With .Font

.Name = "Arial"

.FontStyle = "Normal"

.Size = 10

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

With .ShapeRange

With .Fill

.Visible = msoTrue

.Solid

.ForeColor.SchemeColor = 65

.Transparency = 0#

End With

With .Line

.Weight = 1.5

.DashStyle = msoLineSolid

.Style = msoLineSingle

.Transparency = 0#

.Visible = msoTrue

.ForeColor.SchemeColor = 10

.BackColor.RGB = RGB(255, 255, 255)

End With

End With

.Formula = rnSource.Address()

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ReadingOrder = xlContext

.Orientation = xlHorizontal

.AutoSize = True

.Placement = xlFreeFloating

.PrintObject = True

End With

End Sub[/log]

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.