Move part of table to new tab

rjplante

Well-known Member
Joined
Oct 31, 2008
Messages
558
Office Version
  1. 365
Platform
  1. Windows
I have a table that has the number of columns defined when it is opened for the first time. Column A is always a reference column and the number of columns is entered into cell CF1 and starts in column B. If the user enters 8 columns, there will be nine columns to the table. Some rows will have a single cell with data in it, and others will have multiple cells containing data. I have the data sorted from largest to smallest with respect to number of occurrences of data in the row. I have inserted a blank row where the data has only a single data occurrence in the row. I want to grab the data from A to the end of the table and move it to sheet 2 and insert it at cell A5. My current code and table example appears below. I just need help with the moving the data part. The last two lines are my problem. The last line before the end sub gives me an error: "Run-Time error '438': Object doesn't support this property or method". I would like to just move the data and not copy and paste it, as I want the data completely removed from the first sheet.

Macro:

VBA Code:
Sub SORT_AND_MOVE()

Dim LastRow As Long
Dim MC As Long
Dim LC As Range

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Cells(5, Range("CF1") + 3).Select

Set LC = Cells(LastRow, ActiveCell.Column)

MC = Range("CF1").Value

'   Add formula to outside of table
ActiveCell.Formula = "=COUNTIF(" & ActiveCell.Offset(0, -(MC + 1)).Address(0, 0) & ":" & ActiveCell.Offset(0, -2).Address(0, 0) & "," & ActiveCell.Offset(0, -(MC + 2)).Address(0, 0) & ")"

Range(ActiveCell.Address(0, 0)).AutoFill Destination:=Range(ActiveCell.Address(0, 0) & ":" & LC.Address(0, 0)), Type:=xlFillCopy

'   Sort Largest to smallest

Range("A5:" & LC.Address(0, 0)).Select

ActiveWorkbook.Worksheets("Block Tracking Multiple").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Block Tracking Multiple").Sort.SortFields.Add2 Key _
        :=Range(Cells(5, Range("CF1") + 3).Address(0, 0) & ":" & LC.Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Block Tracking Multiple").Sort
        .SetRange Range("A5:" & LC.Address(0, 0))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'   Enter row between multiple and single entry rows

Cells(4, Range("CF1") + 3).Select

Do Until ActiveCell.Value = 1
    ActiveCell.Offset(1, 0).Select
Loop

ActiveCell.EntireRow.Insert

'   Move Single entry rows to second Single Entry Tab
ActiveCell.Offset(1, -(Range("CF1") + 2)).Select

Sheets("Block Tracking Multiple").Range(ActiveCell.Address(0, 0) & ":" & LC.Address(0, 0)).Copy

Sheets("Block Tracking Single Entry").Range("A5").Paste

End Sub

Table:
Panel Tracking Sheet.xlsm
ABCDEFGHIJK
3Reference RowPanel 1Panel 2Panel 3Panel 4Panel 5Panel 6Panel 7Panel 8
56546546546543
610541054105410543
712151215121512153
81215A1215A1215A2
91218121812182
101407140714072
111509150915092
121604160416042
131776177617762
141854185418542
151854A1854A1854A2
161907190719072
171909190919092
18
199079071
20907A907A1
21120912091
22130313031
23151315131
241604A1604A1
251604B1604B1
26179617961
27190519051
28210221021
29210421041
Block Tracking Multiple
Cell Formulas
RangeFormula
K5:K17,K19:K29K5=COUNTIF(B5:I5,A5)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
B3:AZ3Celldoes not contain a blank value textNO
A3:AZ4Cellcontains a blank value textNO
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
will this work 4 you?
it a formula not a macro tho.
Book6
ABCDEFGHIJKLMNOPQRST
1Reference RowPanel 1Panel 2Panel 3Panel 4Panel 5Panel 6Panel 7Panel 8
2
36546546546549079070000000
41054105410541054907A0907A000000
51215121512151215120912090000000
61215A1215A1215A130313030000000
7121812181218151300015130000
81407140714071604A0000001604A0
91509150915091604B001604B00000
10160416041604179600000179600
11177617761776190500000001905
12185418541854210200000210200
131854A1854A1854A210400000021040
14190719071907
15190919091909
16
17907907
18907A907A
1912091209
2013031303
2115131513
221604A1604A
231604B1604B
2417961796
2519051905
2621022102
2721042104
28
Sheet1
Cell Formulas
RangeFormula
K3:S13K3=INDIRECT(ARRAYTOTEXT(FILTER(ADDRESS(($A$3:$A$27=0)*(ROW(A3:$A$27)+1),1,1),NOT(ISERROR(ADDRESS(($A$3:$A$27=0)*ROW(A3:$A$27),1,1)))))&":"&ADDRESS(ROWS(A1:A27),COUNTA(A1:I1)))
Dynamic array formulas.
 
Upvote 0
Although it is an awesome formula, and thank you for the suggestion, I need to have this data moved and not duplicated.
 
Upvote 0
then, you can try implementing this into ur macro.
themn copy it as values
delete original range
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,194
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top