Excel TABLE - VBA to move cell from one table to another
Page 2 of 2 FirstFirst 12
Results 11 to 17 of 17

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

  1. #11
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,745
    Post Thanks / Like
    Mentioned
    66 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Excel TABLE - VBA to move cell from one table to another

    no thanks- see post#9

  2. #12
    New Member
    Join Date
    Jun 2019
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Excel TABLE - VBA to move cell from one table to another

    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!!!

  3. #13
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,745
    Post Thanks / Like
    Mentioned
    66 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Excel TABLE - VBA to move cell from one table to another

    OK
    I will post amended code later today with comments
    Last edited by Yongle; Jul 8th, 2019 at 03:02 AM.

  4. #14
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,745
    Post Thanks / Like
    Mentioned
    66 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Excel TABLE - VBA to move cell from one table to another

    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
    Code:
    '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
    Code:
    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
    Last edited by Yongle; Jul 8th, 2019 at 05:44 PM.

  5. #15
    New Member
    Join Date
    Jun 2019
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Excel TABLE - VBA to move cell from one table to another

    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!

  6. #16
    New Member
    Join Date
    Jun 2019
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Excel TABLE - VBA to move cell from one table to another

    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.

  7. #17
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,745
    Post Thanks / Like
    Mentioned
    66 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Excel TABLE - VBA to move cell from one table to another

    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
    Code:
    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
    Code:
     
    
    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
    
    ' 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
    
    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
    Last edited by Yongle; Jul 19th, 2019 at 11:16 AM.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •