Hirdetés

  2. Fórumok
  3. OS, alkalmazások
  4. Microsoft Excel topic
  5. (kiemelt téma)
Keresés
  • Téma összefoglaló
    Utoljára frissítve: 2023-11-13 08:31

    LOGOUT

    A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
    Kérdés felvetése előtt olvasd el, ha még nem tetted.

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

  • #44240 darvak senior tag darvak #44239
    Új Válasz #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 #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

Hirdetés