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

• #44234 Mutt senior tag Mutt #44232

  Új Válasz 2020-06-10 12:29:00 #44234

  Ú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 Mutt #44232 üzenetére

  Annyi pontosítás, hogy ahogy nézem a sort könnyebben el lehet érni, vagyis a a kód rövidebb tud lenni.

  illetve annyit finomítottam, hogy csak akkor frissít ha a linkedcell értéke nem jó.

  Sub UpdateLinkedCells()
Dim sp As Shape
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
'hiba esetén menjünk tovább
On Error Resume Next
If sp.DrawingObject.progID Like "*CheckBox*" Then

'a jelőlőnégyzet a TopLeftCell.Column oszlopban található, a sort pedig TopLeftCell.Row adja meg
'a sor és oszlop azonosítókat csal akkor toljuk el a megadott értékkel ha ráférnek még a lapra
If sp.TopLeftCell.Row + sorEltol <= Rows.Count And sp.TopLeftCell.Column + oszlopEltol <= Columns.Count Then
Set rng = Cells(sp.TopLeftCell.Row + sorEltol, sp.TopLeftCell.Column + oszlopEltol)

'frissítsünk ha az új hely máshol van
If Intersect(rng, ActiveSheet.Range(sp.DrawingObject.LinkedCell)) Is Nothing Then
'mentsük át az új helyre az eddigi értéket
rng = ActiveSheet.Range(sp.DrawingObject.LinkedCell)

'töröljük a korábbi hely tartalmát
ActiveSheet.Range(sp.DrawingObject.LinkedCell).ClearContents

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

Next sp

End Sub

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