VBA Excel – Presúvanie riadkov v rámci tabuľky

Presúvanie myšou vo VBA nie je možné, takže zostáva len tá jednoduchšia možnosť:

Dim CopyRange As Range

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim aTable As Range
    Dim aRange As Range

    Set aTable = Range("B3:H22")
    Set aRange = Intersect(Target.Resize(1, 1), aTable.Resize(aTable.Rows.Count, 1))
    If Not aRange Is Nothing Then
        Set CopyRange = aRange.Resize(1, aTable.Columns.Count)
        CopyRange.Copy
        Cancel = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim aTable As Range
    Dim aRange As Range
    Dim srcRange As Range
    Dim dstRange As Range
    Dim tmpValue As Variant

    If Not CopyRange Is Nothing Then
        If Application.CutCopyMode = xlCopy Then
            Set aTable = Range("B3:H22")
            Set aRange = Intersect(Target.Resize(1, 1), aTable.Resize(aTable.Rows.Count, 1))
            If Not aRange Is Nothing Then
                Set srcRange = CopyRange
                Set dstRange = aRange.Resize(1, aTable.Columns.Count)
                tmpValue = dstRange.Value
                dstRange = srcRange.Value
                srcRange = tmpValue
            End If
            Application.CutCopyMode = False
        End If
        Set CopyRange = Nothing
    End If
End Sub

PS: Omylom označený výber riadku sa dá zrušiť pomocou klávesy Escape.

Ďakujem za rýchlu odpoveď, ale je tu nejaký problém. Vypíše to:
Compile error: Only comments may appear after End Sub, End Function or End Property
a ostane to na Private Sub Worksheet_SelectionChange(ByVal Target As Range).
Neviem či je na začiatku správne vložená deklarácia Dim CopyRange As Range.

Deklarácia CopyRange na začiatku je správne. Ak ju odstrániš, tak to prestane vypisovať tú chybovú hlášku?

Z chybovej hlášky to vyzerá tak, že tam máš okrem tohto kódu aj niečo iné. Môžeš vyskúšať vložiť tento kód do nového zošita a overiť, že funguje.

Najprv sa musím ospravedlniť za nezmyselnú zmienku o deklarácii CopyRange. Asi pre oči som nevidel, že je použitá v obidvoch makrách.
Chyba bola u mňa pri prepisovaní makier do aplikácie a kvôli časovej tiesni. Teraz som ich skopíroval tak, ako sú napísané. Výsledok je BIG BANG. Funguje to. Vďaka Vďaka Vďaka.
Funguje to trochu inak ako som v zadaní zamýšľal. Vzájomne sa vymenia riadky, ale nedochádza k posúvaniu riadkov. Je to rozšírenie funkcionality toho, čo som chcel, ale vítam to. Úplne super by to bolo, ak by sa táto funkcionalita dala alternatívne spojiť s požadovaným posúvaním riadkov. Alternatíva by bola volená tým, že by som na cieľovú bunku B4 klikol ľavým, alebo pravým tlačítkom myši (v krajnom prípade kombináciou Ctrl + nejaké písmeno). Neviem, či je to vôbec realizovateľné vo VBA.
Ešte jedna pripomienka: Ak bunka v stĺpci B je prázdna (vymazaná klávesou Delete)- neúplná ale funkčná tabuľka, potom presúvanie neuskutočniť.
Ďakujem, pekný weekend prajem.

Aha, tak to zadanie som predtým nepochopil správne. Takže aj s tým posúvaním riadkov a nepresúvaním na prázdnu bunku by to mohlo vyzerať takto:

Dim Source As Range

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim aTable As Range
    Dim aRange As Range

    Set aTable = Range("B3:H22")
    Set aRange = Intersect(Target.Resize(1, 1), aTable.Resize(aTable.Rows.Count, 1))
    If Not aRange Is Nothing Then
        Set Source = aRange.Resize(1, aTable.Columns.Count)
        Source.Copy
        Cancel = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim aTable As Range
    Dim aRange As Range
    Dim aValue As Variant
    Dim nRows As Integer
    
    If Not Source Is Nothing Then
        If Application.CutCopyMode = xlCopy Then
            Set aTable = Range("B3:H22")
            Set aRange = Intersect(Target.Resize(1, 1), aTable.Resize(aTable.Rows.Count, 1))
            If Not aRange Is Nothing Then
                If Target.Resize(1, 1).Value <> "" Then
                    nRows = Target.Row - Source.Row
                    Select Case Sgn(nRows)
                        Case 1
                            Set aRange = Source.Offset(1)
                        Case -1
                            Set aRange = Target
                        Case 0
                            Set aRange = Nothing
                    End Select
                    If Not aRange Is Nothing Then
                        Set aRange = aRange.Resize(Abs(nRows), aTable.Columns.Count)
                        aValue = Source.Value
                        aRange.Offset(-Sgn(nRows)) = aRange.Value
                        Source.Offset(nRows) = aValue
                    End If
                End If
            End If
            Application.CutCopyMode = False
        End If
        Set Source = Nothing
    End If
End Sub

Vo VBA nie je možné odlíšiť ľavé a pravé tlačidlo myši. Pri ľavom tlačidle sa vyberie bunka, čo spustí udalosť SelectionChange. Pri pravom tlačidle sa síce spustí udalosť BeforeRightClick, ale pred touto udalosťou sa spustí ešte aj SelectionChange, pretože sa zmení vybraná bunka.

Alternatíva pomocou klávesy Ctrl je realizovateľná, ale musí sa využiť Windows API, pretože priamo cez VBA sa nedá zistiť, či bol Ctrl stlačený alebo nie.

Perfektná práca sa chváli sama a tak je to aj v tomto prípade. Klape to ako švajčiarske hodinky. Vďaka
Presúvanie na prázdnu bunku som asi nedostatočne vysvetlil. Terajšie makro funguje tak, že nie je možné presúvať zdrojovú bunku na prázdnu cieľovú bunku. Myslel som to práve opačne, nepresúvať nak na cieľovú bunku, ak zdrojová bunka je prázdna.
Je možné takéto nepresúvanie zaviesť aj do predchádzajúceho makra bez posúvania riadkov?
Ďakujem

O kontrolu prázdnej bunky sa stará táto podmienka:

If Target.Resize(1, 1).Value <> "" Then

Ak to chceš kontrolovať opačne, tak stačí nahradiť Target za Source.

Prípadne to môžeš ošetriť už pri označovaní v metóde Worksheet_BeforeDoubleClick nejako takto:

If Not aRange Is Nothing Then
    If aRange.Value <> "" Then 
        Set Source = aRange.Resize(1, aTable.Columns.Count)
        Source.Copy
        Cancel = True
    End If
End If

Do toho predchádzajúceho makra to dúfam zvládneš dať aj sám.

Tak ešte raz ďakujem