Új hozzászólás Aktív témák

• #44240 darvak senior tag darvak #44239

  Új Válasz 2020-06-10 22:20:22 #44240

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  darvak

  senior tag

  válasz darvak #44239 üzenetére

  Ez már meglett

• #44232 Mutt senior tag darvak #44231

  Új Válasz 2020-06-10 11:46:13 #44232

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz darvak #44231 üzenetére

  Szia,

  ...a Linkedcell cellákat beállítja az aktív munkafüzeten lévő összes beillesztett jelölőnégyzetre egységesen pl. 7 db cellával jobbra...

  Próbáld ki a lenti kódot. A sorEltol és oszlopEltol állandókat változtatva tudod megadni, hogy mennyivel legyenek arrébb a kapcsolt cellák.

  Sub UpdateLinkedCells()
Dim sp As Shape
Dim sor As Long
Dim rng As Range

Const sorEltol As Long = 0
Const oszlopEltol As Long = 7

For Each sp In ActiveSheet.Shapes
'az aktív lapon talált objektumok közül csak a jelölőnégyzeteket keressük meg
If sp.DrawingObject.progID Like "*CheckBox*" Then

'a jelőlőnégyzet a TopLeftCell.Column oszlopban található, de hogy melyik sorban azt
'csak a magassága alapján tudjuk megmondani
sor = getRow(sp.top + sp.Height / 2)

'ha megvannak sor és oszlop azonosítók, akkor toljuk el a megadott értékkel őket ha ráférnek még a lapra
If sor + sorEltol <= Rows.Count And sp.TopLeftCell.Column + oszlopEltol <= Columns.Count Then
Set rng = Cells(sor + sorEltol, sp.TopLeftCell.Column + oszlopEltol)

'mentsük át az új helyre az eddigi értéket
rng = Range(sp.DrawingObject.LinkedCell)

'töröljük a korrábi hely tartalmát
Range(sp.DrawingObject.LinkedCell).ClearContents

'linkeljük be az újat
sp.DrawingObject.LinkedCell = rng.Address
End If
End If

Next sp

End Sub

Function getRow(pos As Double) As Long
Dim c As Long
Dim h As Long

c = 0
h = 0

Do While pos > h
c = c + 1
h = h + ActiveSheet.Cells(c, 1).Height
Loop

getRow = c

End Function

  üdv

Új hozzászólás Aktív témák