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.

 

[Peter_SSs]

campbells

Welcome to the Mr Excel board!

Can you tell us some more about the data to be 'snaked up'?
Is it all text or all numbers or all dates etc?
Are the cells all formatted the same to start with?
Are there any formulas in the area to be moved? If so, is it just the formula result to be moved?

 

[campbells]

Hi Peter,

the data in the cells is simple value/text ...no formulas, and all cells are formated the same.

i think a way to achieve the desired result would be to: take the given user selection, copy it all one cell left (or right), then cut any values that were displaced outside of the box/table/array by this operation, and move them to the oposite side of the array, shiftign them up (or down) one cell.

I'm not familiar with the language used to write macros, but i imagine one approach may be something similar to:


if it was a move/push to the left

{

query selection range (which will usually not be a 'square range' ..but multiple selections of stacked rows).

for each row in the selection, copy/move the range one cell left.

select range of cells in the column that lays outside the array where the selection above was pushed out into, cut and paste it to oposite side of the array, shifting it up one.

}


Please let me know if this makes sense.


The other option might be if excel has a means of wrapping a linear list of data? like word-wrap in a text application?, where i define the range of cells for it to wrap into. dont think it does.

Thankyou,
Campbell.

 

[acw]

Campbell

See if this gets you started. Highlight the block that you want to cover (say A1:E5) then run the macro.

I'm not sure where you expect to get the extra data from, so see if this gets you started.

Sub ccc()
  Dim arr As Variant
  ReDim arr(Selection.Rows.Count, Selection.Columns.Count)
  roww = 0
  coll = 0
  For Each ce In Selection
    If Not IsEmpty(ce) Then
      arr(roww, coll) = ce
      If coll = 4 Then
        roww = roww + 1
        coll = 0
      Else
        coll = coll + 1
      End If
    End If
    
  Next ce
  
  Selection.Value = arr
End Sub

Tony

 

[Peter_SSs]

Campbell

This was my attempt. Post back if this or Tony's solution is not what you want or you need more help with how to implement the suggestions.

Select the required area then run this macro:

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> SnakeData()
    <SPAN style="color:#00007F">Dim</SPAN> FirstRow <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> FirstCol <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> LastRow <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> LastCol <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> k <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> DataCount <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> DataArray()
    
    DataCount = WorksheetFunction.CountA(Selection)
    <SPAN style="color:#00007F">ReDim</SPAN> DataArray(DataCount)
    FirstRow = Selection.Row
    FirstCol = Selection.Column
    LastRow = FirstRow + Selection.Rows.Count - 1
    LastCol = FirstCol + Selection.Columns.Count - 1
    
    k = 1
    <SPAN style="color:#00007F">For</SPAN> i = FirstRow <SPAN style="color:#00007F">To</SPAN> LastRow
        <SPAN style="color:#00007F">For</SPAN> j = FirstCol <SPAN style="color:#00007F">To</SPAN> LastCol
            <SPAN style="color:#00007F">If</SPAN> Cells(i, j) <> "" <SPAN style="color:#00007F">Then</SPAN>
                DataArray(k) = Cells(i, j).Value
                k = k + 1
            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
        <SPAN style="color:#00007F">Next</SPAN> j
    <SPAN style="color:#00007F">Next</SPAN> i
    Selection.ClearContents
    k = 1
    <SPAN style="color:#00007F">For</SPAN> i = FirstRow <SPAN style="color:#00007F">To</SPAN> LastRow
        <SPAN style="color:#00007F">For</SPAN> j = FirstCol <SPAN style="color:#00007F">To</SPAN> LastCol
            <SPAN style="color:#00007F">If</SPAN> k <= DataCount <SPAN style="color:#00007F">Then</SPAN>
                Cells(i, j).Value = DataArray(k)
                k = k + 1
            <SPAN style="color:#00007F">Else</SPAN>
                i = LastRow
                j = LastCol
            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
        <SPAN style="color:#00007F">Next</SPAN> j
    <SPAN style="color:#00007F">Next</SPAN> i
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[campbells]

Thankyou both for these approaches. They dont quite behave as i expected though, and my familiarity with the language isnt sufficient to tweak on top unfortunately. I was thinking of an approach to coding this, and have taken some snap-shots to illustrate the gross steps:

The range that i have selected i want to push left (other case would be to push right, a mirrored process in a separate macro i guess), such that H31 data (pET31c) ends up in G31, and everything else tags along behid it, with the last selected cell contents of I33 (RK600) ending up in H33.

copy the selection chunk left one cell (often not a simple block range, so have to isolate each row to copy one cell left?)

grab any data that has been pushed outside the array..

.. and copy across to opposite side, shifting it up one in the process (should omit any cells in the copy that are empty. for moving right, you'd shift the copied cells down one rather than up).

i hope this helps to clarify the idea, please feel free to ask further questions.

Much appreciated guys,

Campbell.

 

[tusharm]

Lightly tested.

Adjust the Initialize subroutine to your own matrix limits. Currently, it is set for the example you used.

Also, strictly speaking, you don't need to select all the cells that need to be moved. Just selecting the first and last cells is enough.

Finally, the code should be self-explantory. Just look at each routine individually and it should be obvious what it does. The only place where I do something that may need an explanation, I have added a comment.

Option Explicit
Dim MatrixFirstCell As Range, MatrixLastCell As Range
Private Sub Initialize()
    Set MatrixFirstCell = Range("F30")
    Set MatrixLastCell = Range("J34")
    End Sub

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)
    PastLastCell = aCell.Row > LastCell.Row _
        Or (aCell.Row = LastCell.Row And aCell.Column > LastCell.Column)
    End Function
Private Function PastFirstCell(aCell As Range, FirstCell As Range)
    PastFirstCell = aCell.Row < FirstCell.Row _
        Or (aCell.Row = FirstCell.Row And aCell.Column < FirstCell.Column)
    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
        SrcCell.Copy DestCell
        Set SrcCell = NextCell(SrcCell, MatrixFirstCell, MatrixLastCell)
        Set DestCell = PrevCell(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
        SrcCell.Copy DestCell
        Set SrcCell = PrevCell(SrcCell, MatrixFirstCell, MatrixLastCell)
        Set DestCell = NextCell(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, _
        MatrixFirstCell As Range, MatrixLastCell As Range)
    Dim anArea As Range, aCell As Range
    Set FirstCell = MatrixLastCell
    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
Sub moveSelectionRight()
    Dim FirstCell As Range, LastCell As Range
    If MatrixFirstCell Is Nothing Then Initialize
    findFirstLastCells Selection, LastCell, FirstCell, _
        MatrixFirstCell, MatrixLastCell
    moveRight FirstCell, LastCell, MatrixFirstCell, MatrixLastCell
    End Sub
Sub moveSelectionLeft()
    Dim FirstCell As Range, LastCell As Range
    If MatrixFirstCell Is Nothing Then Initialize
    findFirstLastCells Selection, FirstCell, LastCell, _
        MatrixFirstCell, MatrixLastCell
    moveLeft FirstCell, LastCell, MatrixFirstCell, MatrixLastCell
    End Sub

 

[campbells]

tusharm,

Nice one! Appears to largely be behaving correctly, just one particular case where it breaks for when you move data out of the top-right, or bottom-left cells ..that is, if you move data right from top-left corner, or left, from the bottom-right.

If you'd be kind enough, there are a couple of other things that would greatly improve useability:

- update the selection range after a move (that is, shift the selection with the data), .. so that you can do repeated moves on the same block of data w/o having to manually update the selection.

- if it is possible to define the array range/size by a macro that updates the MatrixFirst/LastCell declarations ...where user selects the top-left and bottom-right cells that define the array extents, then runs the 'define-matrix macro'?

Many thanks,
Campbell.

 

[tusharm]

Fixed the bug. Added the suggested enhancement. To define the matrix, select it (or at least the top-left and bottom-right cells) and run Initialize.

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
    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
    moveLeft FirstCell, LastCell, MatrixFirstCell, MatrixLastCell
    On Error Resume Next
    Application.Union( _
        PrevCell(FirstCell, MatrixFirstCell, MatrixLastCell), _
        PrevCell(LastCell, MatrixFirstCell, MatrixLastCell)).Select
    End Sub

 

[campbells]

Brilliant, thanks tusharm! Greatly appreciate your efforts - you've saved a bunch of time here (microbiology lab, sorting out 1000's of bacterial strains in boxes, in towers, in freezer chests).

One last request, which im afraid wont be possible to grant - is there any possibility of an undo? VB commands cant be undone? (its just that you can in some instances loose data if you do moves on selections that are outside the currently defined matrix).


Much obliged,
Campbell.