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]

trying to understand exactly what you want
Is it this?

start with ...

Excel 2016 (Windows) 32 bit

	A​	B​	C​	D​
1​	ColA	ColB	ColC	ColD
2​	A001	B001	C001	A005
3​	A002		C002	A006
4​	A003	B003	C003
5​	A004	B004	C004	A008
6​
7​
8​
9​
10​
11​	ColA	ColB	ColC	ColD
12​	A040	B040	C040	A040
13​	A041	B041	C041	A041
14​	A042	B042	C042	A042

Sheet: Before

move cell and move other cells down ...

Excel 2016 (Windows) 32 bit

	A​	B​	C​	D​
1​	ColA	ColB	ColC	ColD
2​	A001	B001	C001	A005
3​	A002		C002	A006
4​	A003	B003	C003
5​	A004	C041	C004	A008
6​		B004
7​
8​
9​
10​
11​	ColA	ColB	ColC	ColD
12​	A040	B040	C040	A040
13​	A041	B041		A041
14​	A042	B042	C042	A042

Sheet: AfterMove

and sort - Table 1 sorted , Table2 unsorted

Excel 2016 (Windows) 32 bit

	A​	B​	C​	D​
1​	ColA	ColB	ColC	ColD
2​	A001	A005	B003	C003
3​	A002	A006	B004	C004
4​	A003	A008	C001	C041
5​	A004	B001	C002
6​
7​
8​
9​
10​	ColA	ColB	ColC	ColD
11​	A040	B040	C040	A040
12​	A041	B041		A041
13​	A042	B042	C042	A042

Sheet: AfterSort

 

[giantg]

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]

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]

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]

so when does it become 4 columns ?

 

[giantg]

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]

Thanks
- will post code tomorrow

 

[Yongle]

Before (1)

Excel 2016 (Windows) 32 bit

	K​	L​	M​	N​	O​	P​	Q​	R​	S​
1​	Header1	Header2	Header3	Header4		Header1	Header2	Header3	Header4
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​	Header1	Header2	Header3	Header4		Header1	Header2	Header3	Header4
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​	Header1	Header2	Header3	Header4		Header1	Header2	Header3	Header4
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​	Header1	Header2	Header3	Header4		Header1	Header2	Header3	Header4
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

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

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]

Thanks. I'll test it out today and let you know if it works as planned. Thanks for the help!