macro to push, 'snake', data through a 'table'

[campbells]

Greetings,

Great forum!

I was wondering if there may exist a macro, or indeed a built in method, that would allow me to push data through a 'table'. Example will probably illustrate what i mean best: imagine a 5x5 array of cells with data in each cell, except, say, the first 2 cells of row 1 ...what i would like to do is be able to 'push' or 'snake' the data from everything behind row 1, cell 2 so that it butts up to row 1 cell 1, which would end up leaving a gap at the end of the table, row 5's last two cells ....so the data kind of loops or snakes back aroudn to the other side as you push it about. This is probably fairly easily implemented in a macro using serries of pastes, copies and modal size of a the selection your moving. Feel free to ask more questions if you need clarification on this. Kind of a 'looping push'. As you move data along from one row, as it 'runs out' it picks up data from the row above or below ...mm, perhaps a better metaphore: like having a paragraph of text, if you remove some of the words, the words after these will snake up and join up to the position before the deleted words ...squirming in to fit the width of the paragraph block (the 'table') ...likewise, if you add more words, the words after those are pushed along, looping back left-to-right.


Much Obliged,
Campbell.

 

[tusharm]

Glad it worked for you. I believe the below disallows cell selection outside the currently defined matrix.

Option Explicit
Dim MatrixFirstCell As Range, MatrixLastCell As Range

Private Function ValidCell(aCell As Range, _
        MatrixFirstCell As Range, MatrixLastCell As Range) As Boolean
    ValidCell = aCell.Row >= MatrixFirstCell.Row _
        And aCell.Column >= MatrixFirstCell.Column _
        And aCell.Row <= MatrixLastCell.Row _
        And aCell.Column <= MatrixLastCell.Column
    End Function

Private Function PrevCell(aCell As Range, _
        MatrixFirstCell As Range, MatrixLastCell As Range) As Range
    If Not ValidCell(aCell, MatrixFirstCell, MatrixLastCell) Then _
        Exit Function
    If aCell.Column > MatrixFirstCell.Column Then
        Set PrevCell = aCell.Offset(0, -1)
    ElseIf aCell.Row = MatrixFirstCell.Row Then
        Set PrevCell = Nothing
    Else
        Set PrevCell = aCell.Parent.Cells(aCell.Row - 1, MatrixLastCell.Column)
        End If
    End Function
Private Function NextCell(aCell As Range, _
        MatrixFirstCell As Range, MatrixLastCell As Range) As Range
    If Not ValidCell(aCell, MatrixFirstCell, MatrixLastCell) Then _
        Exit Function
    If aCell.Column < MatrixLastCell.Column Then
        Set NextCell = aCell.Offset(0, 1)
    ElseIf aCell.Row = MatrixLastCell.Row Then
        Set NextCell = Nothing
    Else
        Set NextCell = aCell.Parent.Cells(aCell.Row + 1, MatrixFirstCell.Column)
        End If
    End Function

Private Function PastLastCell(aCell As Range, LastCell As Range)
    If aCell Is Nothing Then
        PastLastCell = True
    Else
        PastLastCell = aCell.Row > LastCell.Row _
            Or (aCell.Row = LastCell.Row _
                And aCell.Column > LastCell.Column)
        End If
    End Function
Private Function PastFirstCell(aCell As Range, FirstCell As Range)
    If aCell Is Nothing Then
        PastFirstCell = True
    Else
        PastFirstCell = aCell.Row < FirstCell.Row _
            Or (aCell.Row = FirstCell.Row _
                And aCell.Column < FirstCell.Column)
        End If
    End Function

Private Sub moveLeft(StartCell As Range, EndCell As Range, _
        MatrixFirstCell As Range, MatrixLastCell As Range)
    'StartCell is "nearer" MatrixFirstCell then EndCell
    Dim SrcCell As Range, DestCell As Range
    Set DestCell = PrevCell(StartCell, MatrixFirstCell, MatrixLastCell)
    If DestCell Is Nothing Then Exit Sub
    If Not IsEmpty(DestCell.Value) Then Exit Sub
    Set SrcCell = StartCell
    Do
        Set DestCell = PrevCell(SrcCell, MatrixFirstCell, MatrixLastCell)
        SrcCell.Copy DestCell
        Set SrcCell = NextCell(SrcCell, MatrixFirstCell, MatrixLastCell)
        Loop Until PastLastCell(SrcCell, EndCell)
    EndCell.ClearContents
    End Sub
Private Sub moveRight(StartCell As Range, EndCell As Range, _
        MatrixFirstCell As Range, MatrixLastCell As Range)
    'StartCell is "nearer" MatrixLastCell then EndCell
    Dim SrcCell As Range, DestCell As Range
    Set DestCell = NextCell(StartCell, MatrixFirstCell, MatrixLastCell)
    If DestCell Is Nothing Then Exit Sub
    If Not IsEmpty(DestCell.Value) Then Exit Sub
    Set SrcCell = StartCell
    Do
        Set DestCell = NextCell(SrcCell, MatrixFirstCell, MatrixLastCell)
        SrcCell.Copy DestCell
        Set SrcCell = PrevCell(SrcCell, MatrixFirstCell, MatrixLastCell)
        Loop Until PastFirstCell(SrcCell, EndCell)
    EndCell.ClearContents
    End Sub
    Private Function updateFirstCell( _
            CurrCell As Range, NewCell As Range) As Range
        If NewCell.Row < CurrCell.Row Then
            Set updateFirstCell = NewCell
        ElseIf NewCell.Row = CurrCell.Row And NewCell.Column < CurrCell.Column Then
            Set updateFirstCell = NewCell
        Else
            Set updateFirstCell = CurrCell
            End If
        End Function
    Private Function updateLastCell( _
            CurrCell As Range, NewCell As Range) As Range
        If NewCell.Row > CurrCell.Row Then
            Set updateLastCell = NewCell
        ElseIf NewCell.Row = CurrCell.Row And NewCell.Column > CurrCell.Column Then
            Set updateLastCell = NewCell
        Else
            Set updateLastCell = CurrCell
            End If
        End Function
Private Sub findFirstLastCells(aRng As Range, _
        ByRef FirstCell As Range, ByRef LastCell As Range, _
        Optional MatrixFirstCell As Range, _
        Optional MatrixLastCell As Range)
    Dim anArea As Range, aCell As Range
    If MatrixLastCell Is Nothing Then _
        Set FirstCell = Cells(Rows.Count, Columns.Count) _
    Else _
        Set FirstCell = MatrixLastCell
    If MatrixFirstCell Is Nothing Then _
        Set LastCell = Cells(1, 1) _
    Else _
        Set LastCell = MatrixFirstCell
    For Each anArea In aRng.Areas
        For Each aCell In anArea.Cells
            Set FirstCell = updateFirstCell(FirstCell, aCell)
            Set LastCell = updateLastCell(LastCell, aCell)
            Next aCell
        Next anArea
    End Sub
Public Sub Initialize()
    findFirstLastCells Selection, MatrixFirstCell, MatrixLastCell
    End Sub
Sub moveSelectionRight()
    Dim FirstCell As Range, LastCell As Range
    If MatrixFirstCell Is Nothing Then
        Beep
        MsgBox "First, establish the matrix limits by " _
            & "selecting it and running the 'Initialize' procedure"
        Exit Sub
        End If
    findFirstLastCells Selection, LastCell, FirstCell, _
        MatrixFirstCell, MatrixLastCell
    If Not (ValidCell(FirstCell, MatrixFirstCell, MatrixLastCell) _
            And ValidCell(LastCell, MatrixFirstCell, MatrixLastCell)) Then
        Beep
        MsgBox "First and last cells for a move must be within defined matrix"
        Exit Sub
        End If
    moveRight FirstCell, LastCell, MatrixFirstCell, MatrixLastCell
    On Error Resume Next
    Application.Union( _
        NextCell(FirstCell, MatrixFirstCell, MatrixLastCell), _
        NextCell(LastCell, MatrixFirstCell, MatrixLastCell)).Select
    End Sub
Sub moveSelectionLeft()
    Dim FirstCell As Range, LastCell As Range
    If MatrixFirstCell Is Nothing Then
        Beep
        MsgBox "First, establish the matrix limits by " _
            & "selecting it and running the 'Initialize' procedure"
        Exit Sub
        End If
    findFirstLastCells Selection, FirstCell, LastCell, _
        MatrixFirstCell, MatrixLastCell
    If Not (ValidCell(FirstCell, MatrixFirstCell, MatrixLastCell) _
            And ValidCell(LastCell, MatrixFirstCell, MatrixLastCell)) Then
        Beep
        MsgBox "First and last cells for a move must be within defined matrix"
        Exit Sub
        End If
    moveLeft FirstCell, LastCell, MatrixFirstCell, MatrixLastCell
    On Error Resume Next
    Application.Union( _
        PrevCell(FirstCell, MatrixFirstCell, MatrixLastCell), _
        PrevCell(LastCell, MatrixFirstCell, MatrixLastCell)).Select
    End Sub

 

[campbells]

Perfect, works a treat.

Thankyou tusharm.

Cheers,
Campbell.

 

[tusharm]

You are welcome.

Perfect, works a treat.

Thankyou tusharm.

Cheers,
Campbell.