Excel TABLE - VBA to move cell from one table to another

[giantg]

New to VBA and trying to piece together a macro but the table part is causing me problems.

I have multiple "3 or 4 column" tables on a worksheet. I want to move a cell value by Double Clicking the cell on one table, then click anywhere on another table to move that cell value to that table. When the value moves, needs to remove blanks and sort.

I need the table columns to be sorted as if they were all stacked in one column, then split back to three (or four depending on how many columns are in the table).

Any help is appreciated. Please let me know if you need more details.

 

[Yongle]

no thanks- see post#9

 

[giantg]

Thanks Yongle for your code. Unfortunately, I cannot get it to work as planned. When I click on a cell in one table (bin A), then click the next table (bin C), its not moving the cell. It causes a whole column over and overwrites the headers. I tried many times to understand the code, but I am still an amateur. I will stick to just 3 columns per table, this should help simplify. These are all "excel tables" with named tables (table1, table2, table3, etc) and named headers. I was assuming I'd need to use Listobject or Listcolumn. Thanks again for your help!!!

 

[Yongle]

OK
I will post amended code later today with comments

 

[Yongle]

I was assuming I'd need to use Listobject or Listcolumn

- alternative using ListObjects
- this time without using temporary worksheet

This works for me
Test in a new worksheet
The code goes in sheet module

'must place at top of module
Option Explicit

Private Const msg = "Click on other table and click OK", ttl = "Move a value to another bin"
Private cel As Range, rng As Range, aRange As Range
Private bin As ListObject, Bin1 As ListObject, Bin2 As ListObject
Private A As Variant, W As Variant
Private r1 As Long, r2 As Long, r3 As Long, nCount As Long

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.CountLarge > 1 Or Target.Row = 1 Then Exit Sub
    
'identify the 2 bins
    On Error Resume Next
    Set Bin1 = Target.ListObject
    Set Bin2 = Application.InputBox(msg, ttl, , , , , , 8).ListObject
    If Err.Number > 0 Then End
'housekeeping etc
    Cancel = True
    Set A = Application: Set W = A.WorksheetFunction
    A.ScreenUpdating = False
'move the cell, sort the data, delete empty rows
    Call InOrder(Target, Bin2)
    Call InOrder(Target, Bin1)
    Call In3Cols(Bin2)
    Call In3Cols(Bin1)
    Call DeleteEmptyRows(Bin2)
    Call DeleteEmptyRows(Bin1)
End Sub

Private Sub InOrder(aRange, bin)
    With bin
'move everything to first column for sorting
        For Each cel In Union(aRange, .ListColumns(3).DataBodyRange, .ListColumns(2).DataBodyRange)
            .Range.Offset(.Range.Rows.Count).Resize(1, 1) = cel
            cel.ClearContents
        Next cel
        .Range.Sort key1:=.Range.Cells(1, 1), order1:=xlAscending, Header:=xlYes
    End With
End Sub

Private Sub In3Cols(bin)
'how many items in each column
    nCount = W.Count(bin.DataBodyRange)
    r3 = W.RoundDown(nCount / 3, 0)
    r2 = r3
    r1 = nCount - r2 - r3
    Set cel = bin.DataBodyRange.Cells(1, 1)
'move to column 2
    Set rng = cel.Offset(r1).Resize(r2)
    cel.Offset(, 1).Resize(r2).Value = rng.Value
    rng.ClearContents
'move to column 3
    Set rng = cel.Offset(r1 + r2).Resize(r3)
    cel.Offset(, 2).Resize(r3) = rng.Value
    rng.ClearContents
End Sub

Private Sub DeleteEmptyRows(bin)
    On Error Resume Next
    Set rng = bin.DataBodyRange.Resize(, 1).SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not rng Is Nothing Then rng.Resize(, 3).Delete Shift:=xlUp
End Sub

 

[giantg]

This works great! I was having some trouble at first, but made one minor change to the code due to the cells being text.
I changed "W.Count(bin.DataBodyRange)" to "W.CountA(bin.DataBodyRange)", now it works as planned!

 

[giantg]

As I enhance this tool, I have a few additional asks for help. I attempted to do some of these and cant get it right:

• I’d like to remove the InputBox and instead have the cell from Bin1 highlighted, then next click moves to Bin2.
• If possible, can clicking only the tables (bins) initiate the vba, instead of anywhere on the sheet?
• In the future as my content grows, I think I may need to select ranges from one Bin and move to another Bin in the same manner. Not sure how complex that would be.

Thanks again for any help.

 

[Yongle]

I’d like to remove the InputBox and instead have the cell from Bin1 highlighted, then next click moves to Bin2
If possible, can clicking only the tables (bins) initiate the vba, instead of anywhere on the sheet?
In the future as my content grows, I think I may need to select ranges from one Bin and move to another Bin in the same manner. Not sure how complex that would be.

See if this is close to what you want

Select cells to move in Bin1 and RIGHT-CLICK on any one of those cells
After confirmation the values are given a red font
Click on any cell in the data area in Bin2 to move the values there


PLACE CODE BELOW IN SHEET MODULE

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal target As Range, Cancel As Boolean)
     If target.Cells.CountLarge < 1000 And IsTable(target) Then
        If MsgBox("Move selected cells to another table", vbYesNo, "") = vbYes Then
            Cancel = True
            Call KutCells(target)
        Else
            Call CleanUp
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
    If Not Bin1 Is Nothing And target.Cells.CountLarge = 1 And IsTable(target) Then
        Call MoveCells(target)
    Else
        Call CleanUp
    End If
End Sub

PLACE CODE BELOW IN AN EMPTY STANDARD MODULE

Option Explicit

Public Values As Range
Public Bin1 As ListObject, Bin2 As ListObject

Public Sub KutCells(target As Range)
    Set Values = target
    Set Bin1 = Values.ListObject
    Values.Font.Color = vbRed
End Sub

Public Sub MoveCells(target As Range)
    Set Bin2 = target.ListObject
    Call AddDummy               'see NOTE below
    Call PutInOrder(Union(Values, Bin2.DataBodyRange), Bin2)
    Call PutInOrder(Bin1.DataBodyRange, Bin1)
    Call DeleteDummy
    Call CleanUp
End Sub

Function IsTable(rng) As Boolean
    Dim t As Boolean, cel As Range
    On Error Resume Next
    t = True
    For Each cel In rng
        If cel.ListObject Is Nothing Then t = False
        If Not Intersect(cel, cel.ListObject.HeaderRowRange) Is Nothing Then t = False
        If Err.Number > 0 Then t = False
    Next
    IsTable = t
End Function

Public Sub PutInOrder(rng As Range, aBin As ListObject)
    Dim cel As Range
    Application.ScreenUpdating = False
    
    With aBin
        'move everything to first column for sorting
        For Each cel In rng
            .Range.Offset(.Range.Rows.Count).Resize(1, 1) = cel
            cel.ClearContents
        Next cel
        .Range.Sort key1:=.Range.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        .Range.Font.Color = 0
    End With
    Call ThreeColumns(aBin)
End Sub

Public Sub DeleteEmptyRows(aBin As ListObject)
    On Error Resume Next
    Dim r As Long
    For r = aBin.DataBodyRange.Rows.Count To 1 Step -1
        If aBin.DataBodyRange.Cells(r, 1) = "" Then aBin.DataBodyRange.Rows(r).Delete
    Next r
End Sub

Public Sub ThreeColumns(aBin As ListObject)
    Dim nCount As Long, w As Object, rng As Range, cel As Range
    Dim R1 As Long, R2 As Long, R3 As Long

'how many items in each column
    Call DeleteEmptyRows(aBin)
    nCount = aBin.DataBodyRange.Rows.Count
    If nCount >= 6 Then
        R1 = CInt(nCount / 3)
        R3 = R1 + 1
        R2 = nCount - R1 - R3
        Set cel = aBin.DataBodyRange.Cells(1, 1)
'move to column 2
        Set rng = cel.Offset(R1).Resize(R2)
        cel.Offset(, 1).Resize(R2).Value = rng.Value
        rng.ClearContents
'move to column 3
        Set rng = cel.Offset(R1 + R2).Resize(R3)
        cel.Offset(, 2).Resize(R3) = rng.Value
        rng.ClearContents
    End If
'delete empty rows
    Call DeleteEmptyRows(aBin)
End Sub

Sub CleanUp()
    Set Values = Nothing
    Set Bin1 = Nothing
    Set Bin2 = Nothing
End Sub

[COLOR=#ff0000]' NOTE
' code below included to force one additional value into each bin
' .DataBodyRange throws an error if the table is empty
' this lazy workaround avoids that problem[/COLOR]

Public Sub AddDummy()
    Bin1.Range.Offset(Bin1.Range.Rows.Count).Resize(1, 1) = "ZZZZZZ"
    Bin2.Range.Offset(Bin2.Range.Rows.Count).Resize(1, 1) = "ZZZZZZ"
End Sub

Public Sub DeleteDummy()
    Dim cel As Range
    For Each cel In Union(Bin1.DataBodyRange, Bin2.DataBodyRange)
        If cel = "ZZZZZZ" Then cel.ClearContents
    Next cel
End Sub