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

giantg

New Member
Joined
Jun 28, 2019
Messages
9
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

Well-known Member
Joined
Mar 11, 2015
Messages
4,672
Office Version
365
Platform
Windows
trying to understand exactly what you want :confused:
Is it this?

start with ...

Excel 2016 (Windows) 32 bit
A
B
C
D
1
ColAColBColCColD
2
A001B001C001A005
3
A002C002A006
4
A003B003C003
5
A004B004C004A008
6
7
8
9
10
11
ColAColBColCColD
12
A040B040C040A040
13
A041B041C041A041
14
A042B042C042A042
Sheet: Before

move cell and move other cells down ...

Excel 2016 (Windows) 32 bit
A
B
C
D
1
ColAColBColCColD
2
A001B001C001A005
3
A002C002A006
4
A003B003C003
5
A004C041C004A008
6
B004
7
8
9
10
11
ColAColBColCColD
12
A040B040C040A040
13
A041B041A041
14
A042B042C042A042
Sheet: AfterMove

and sort - Table 1 sorted , Table2 unsorted

Excel 2016 (Windows) 32 bit
A
B
C
D
1
ColAColBColCColD
2
A001A005B003C003
3
A002A006B004C004
4
A003A008C001C041
5
A004B001C002
6
7
8
9
10
ColAColBColCColD
11
A040B040C040A040
12
A041B041A041
13
A042B042C042A042
Sheet: AfterSort
 

giantg

New Member
Joined
Jun 28, 2019
Messages
9
Imagine they are bins. Three or Four columns wide in order to avoid long columns. Then moving items from one bin to another and sorting them entire bin... removing blanks and potentially unused rows. The bins are from left to right (columns A,B,C....F,G,H...K,L,M...etc). I can draw an example today when I get to my desk. Thanks for helping.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,672
Office Version
365
Platform
Windows
1. Are there headers in row 1 ?

Imagine they are bins. Three or Four columns wide in order to avoid long columns
2. Which is the last permitted row number ?
 

giantg

New Member
Joined
Jun 28, 2019
Messages
9
1. Are there headers in row 1 ?
Yes, the headers are Acol1, Acol2 Acol3...Bcol1, Bcol2, Bcol3... etc. I will have a button stretched over the headers to label the group "A", "B", etc.


2. Which is the last permitted row number ?
No limit, the table row length will grow or shrink depending on the number of used cells. Ex: 100 cells used in table of 3 columns, then 100/3 = 34 rows... move a cell out, then 99/3 = 33 rows.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,672
Office Version
365
Platform
Windows
so when does it become 4 columns ?
 

giantg

New Member
Joined
Jun 28, 2019
Messages
9
Some are three, some are four (as there will be a higher volume in one table than others). If necessary, I can have all as three columns to start.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,672
Office Version
365
Platform
Windows
Thanks
- will post code tomorrow
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,672
Office Version
365
Platform
Windows
Before (1)

Excel 2016 (Windows) 32 bit
K
L
M
N
O
P
Q
R
S
1
Header1Header2Header3Header4Header1Header2Header3Header4
2
14​
143​
277​
8​
319​
636​
3
94​
149​
426​
8​
320​
642​
4
98​
666​
582​
9​
332​
645​
5
126​
220​
645​
9​
336​
657​
6
11​
340​
677​
7
11​
347​
681​
8
11​
355​
683​
9
22​
370​
746​
10
23​
374​
747​
11
23​
374​
748​
12
31​
374​
749​
13
51​
375​
762​
14
54​
380​
766​
15
55​
386​
772​
16
56​
494​
780​
17
64​
497​
782​
18
66​
510​
782​
19
66​
513​
797​
20
110​
544​
802​
21
122​
552​
804​
22
123​
568​
810​
23
135​
575​
810​
24
166​
578​
811​
25
247​
580​
820​
26
250​
581​
832​
27
263​
591​
836​
28
292​
592​
845​
29
295​
599​
845​
30
300​
601​
847​
31
305​
605​
849​
32
318​
620​
851​
33
318​
623​
854​
34
319​
629​
925​
35
Sheet: Tables

After (1)


Excel 2016 (Windows) 32 bit
K
L
M
N
O
P
Q
R
S
1
Header1Header2Header3Header4Header1Header2Header3Header4
2
14​
143​
426​
8​
263​
513​
747​
3
94​
149​
582​
8​
292​
544​
748​
4
98​
220​
645​
9​
295​
552​
749​
5
126​
277​
9​
300​
568​
762​
6
11​
305​
575​
766​
7
11​
318​
578​
772​
8
11​
318​
580​
780​
9
22​
319​
581​
782​
10
23​
319​
591​
782​
11
23​
320​
592​
797​
12
31​
332​
599​
802​
13
51​
336​
601​
804​
14
54​
340​
605​
810​
15
55​
347​
620​
810​
16
56​
355​
623​
811​
17
64​
370​
629​
820​
18
66​
374​
636​
832​
19
66​
374​
642​
836​
20
110​
374​
645​
845​
21
122​
375​
657​
845​
22
123​
380​
666​
847​
23
135​
386​
677​
849​
24
166​
494​
681​
851​
25
247​
497​
683​
854​
26
250​
510​
746​
925​
27
Sheet: Tables


Before (2)

Excel 2016 (Windows) 32 bit
F
G
H
I
J
K
L
M
N
1
Header1Header2Header3Header4Header1Header2Header3Header4
2
14​
151​
677​
14​
143​
426​
3
94​
166​
681​
94​
149​
582​
4
98​
220​
683​
98​
220​
645​
5
126​
277​
811​
126​
277​
6
143​
426​
925​
7
149​
645​
974​
8
Sheet: Tables

After (2)

Excel 2016 (Windows) 32 bit
F
G
H
I
J
K
L
M
N
1
Header1Header2Header3Header4Header1Header2Header3Header4
2
14​
151​
677​
14​
143​
426​
3
94​
166​
681​
94​
149​
582​
4
98​
220​
811​
98​
220​
645​
5
126​
277​
925​
126​
277​
683​
6
143​
426​
974​
7
149​
645​
8
Sheet: Tables


Code:
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Table2 As Range, cel As Range, ws As Worksheet, Bin1 As Range, Bin2 As Range
    If Target.CountLarge > 1 Or Target.Row = 1 Then Exit Sub
    Cancel = True
'which bin ?
    On Error Resume Next
        Set Bin2 = Application.InputBox("Click on other table and click OK", "Move a value to another bin", , , , , , 8)
    On Error GoTo 0
    If Err.Number > 0 Or Bin2.Column Mod 5 = 0 Then Exit Sub
'bin ranges
    Set Bin2 = GetBin(Bin2)
    Set Bin1 = GetBin(Target)

    Call MoveAndSort(Bin2, Target)
    Call MoveAndSort(Bin1)

End Sub
Code:
Private Function GetBin(cell As Range) As Range
    Set GetBin = Cells(2, cell.Column).Offset(, 1 - (cell.Column Mod 5)).Resize(1000, 4)
End Function

Private Sub MoveAndSort(Bin As Range, Optional cell As Range)
    Application.ScreenUpdating = False
    Dim ws As Worksheet, Itm As Range
    Dim itmCount As Long, colCount As Long, rowCount As Long, itmRow As Long, r As Long, c As Long
[COLOR=#006400]'sort in temp sheet[/COLOR]
    Set ws = Sheets.Add
    If Not cell Is Nothing Then
        ws.Cells(1, 1) = cell
        cell.ClearContents
    End If
    For Each Itm In Bin
        If Not Itm = "" Then ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = Itm
    Next Itm
[COLOR=#006400]'sort the data and clear bin[/COLOR]
    ws.Columns("A").Sort key1:=ws.Range("A1"), order1:=xlAscending, Header:=xlNo
    Bin.ClearContents
    itmCount = ws.Cells(Rows.Count, 1).End(xlUp).Row
[COLOR=#006400]'determine number of columns and rows[/COLOR]
    If itmCount > [COLOR=#ff0000]99[/COLOR] Then colCount = 4 Else colCount = 3
    rowCount = (itmCount - itmCount Mod colCount) / colCount
    If itmCount Mod colCount > 0 Then rowCount = rowCount + 1
[COLOR=#006400]'write back to bin[/COLOR]
    For c = 0 To colCount - 1
        For r = 0 To rowCount - 1
            itmRow = itmRow + 1
            Bin.Cells(1, 1).Offset(r, c) = ws.Cells(itmRow, 1)
        Next r
    Next c
[COLOR=#006400]'tidy up[/COLOR]
    Application.DisplayAlerts = False:  ws.Delete:  Application.DisplayAlerts = True
End Sub
NOTES
- the number of columns increases from 3 to 4 if the number of items exceeds 99
- place all the code in the SHEET module
- double-click on "value to move" and click "any cell in other bin" and click OK
- ensure double-click inside the cell (NOT on cell border)
- test exactly as posted before amending anything
 

giantg

New Member
Joined
Jun 28, 2019
Messages
9
Thanks. I'll test it out today and let you know if it works as planned. Thanks for the help!
 
Last edited:

Forum statistics

Threads
1,082,126
Messages
5,363,315
Members
400,725
Latest member
excelingtolearn

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top