Telefonszámunk: 1-472-0679

Hozzászólás: [Resolved] Egy cella tartalmának automatikus átmásolása egérkattintásra egy másik cellába

Kezdőlap Fórumok Excel témák [Resolved] Egy cella tartalmának automatikus átmásolása egérkattintásra egy másik cellába Hozzászólás: [Resolved] Egy cella tartalmának automatikus átmásolása egérkattintásra egy másik cellába

#7137
delila
Felhasználó

    Szia Attila!

    Lemaradt a csatolás, de nem baj.
    Két makrót írtam. Az elsőt a Munka1 laphoz kell rendelned (lapfülön jobb klikk, Kód megjelenítése. Ezzel beléptél a VB szerkesztőbe. Bal oldalon látod a füzeted nevét, azon belül a Munka1 lapot. A jobb oldalon lévő üres területre kell bemásolnod a lenti kódot):

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
        Dim ide As Long
    
        If Target.Column = 1 Then
            Cells(Target.Row, 1).Copy Sheets("Munka2").Cells(1)
            ugras
        End If
    End Sub

    A másik makró modulba kerül. A VB szerkesztőben a füzeteden állva Insert menü, Module. Erre kapsz egy Module1 nevű modult, jobb oldalra másold a makrót:

    Sub ugras()
        Sheets("Munka2").Select
        Cells(1).Select
    End Sub

    Ezután visszatérve a füzetedbe, a Munka1 lap A oszlopában bármelyik cellán duplakikk, a Munka2 A1 cellájában megjelenik a kiválasztott cikkszám, a Munka2 lesz aktív, ott is az A1 cella.
    _________________________________________________________________________________________________________________________________________

    Előfordulhat, hogy a kiválasztott cikkszámokat a Munka2 lapon egymás alá szeretnéd átvinni, mindig az első üres sorba. Ebben az esetben a laphoz ez jön:

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
        Dim ide As Long
    
        If Target.Column = 1 Then
            ide = Sheets("Munka2").Range("A" & Rows.Count).End(xlUp).Row + 1
            Cells(Target.Row, 1).Copy Sheets("Munka2").Cells(ide, 1)
            ugras ide
        End If
    End Sub

    … a modulba pedig:

    Sub ugras(ide)
        Sheets("Munka2").Select
        Cells(ide,1).Select
    End Sub

    Vagy az egyik, vagy a másik párost másold be a Vb szerkesztőbe.

    Üdv,
    Kati

    • A hozzászólás módosításra került: 3 years, 11 months telt el-delila. Indok: Javítás
    • A hozzászólás módosításra került: 3 years, 11 months telt el-delila.