How to copy entire row to a new sheet based on values in column A

xtremegrump · Nov 24, 2011

I am trying to copy the entire row based on values in column A. I have 13237 rows of data. Column A is grouped into about 200 categories with corresponding data in B-F. I would like this to automatically copy the data into new tabs based on the groups in column A. I would also like the tab to be renamed to the value in column A. I appreciate any help.

Excel Workbook

A

B

C

D

E

F

1

Locator

Item

SERIAL_NUMBER

LOT_NUMBER

ON_HAND

UOM

2

01.REEF..

22700300100

22813

6

EA

3

01.REEF..

22643400000

33112

2

EA

4

01.REEF..

K20-745-000

53112

4

EA

5

01.REEF..

K20-618-000

53113

2

EA

6

01.REEF..

22747300000

112211

1

EA

7

01.REEF..

22747300000

120511

11

EA

8

01.SHED..

K45-037-000

451

LB

9

01.SHED..

K45-022-000

10

GA

10

01.SHED..

K45-019-000

5

DR

11

01.SHED..

K45-021-000

22

DR

12

01.SHED..

K45-038-000

595

LB

13

01.SHED..

K10-319-000

3

DR

14

04.FRZR..

R74-001-002

1010000585

15943

GM

15

04.QM.LAB.

K55-002-000

11112

300

EA

16

2351...

R01-608-000

1208

FT

17

2700.9.9.9

P22-307-000

5

EA

18

2700.9.9.9

21002008994

100

EA

19

A12.A.1.

21507118400

371

EA

20

A12.A.1.

A30-271-580

62

EA

21

A12.A.1.

21507218100

461

EA

22

A12.A.10.

21702104385

50

EA

23

A12.A.10.

21502312990

105

EA

24

A12.A.10.

21507214200

34

EA

25

A12.A.10.

21507217700

28

EA

26

A12.A.10.

21507215800

91

EA

27

A12.A.11.

22506300000

400

EA

28

A12.A.11.

22187340300

3000

EA

29

A12.A.11.

22505308200

437

EA

30

A12.A.11.

21702133399

25

EA

31

A12.A.11.

21502341300

19

EA

32

A12.A.11.

22173540000

210

EA

33

A12.A.2.

A36-000-010

10

EA

34

A12.A.2.

A50-010-002

228

EA

35

A12.A.2.

21505213598

210

EA

36

A12.A.2.

21702139585

22

EA

37

A12.A.2.

21502316097

1077

EA

38

A12.A.3.

21509202699

310

EA

39

A12.A.3.

21702107799

36

EA

40

A12.A.3.

A30-903-055

40

EA

41

A12.A.3.

21507118696

154

EA

42

A12.A.3.

22505336489

25

EA

43

A12.A.3.

21702113499

28

EA

44

A12.A.3.

21702109685

27

EA

M195_-_Subinventory_Item_Locato

Andrew Poulsom · Nov 24, 2011

Try:

Code:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim ShNew As Worksheet
    Application.ScreenUpdating = False
'   *** Change Sheet name to suit ***
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A2:A" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("A1:F" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row)
    For Each Item In List
        Set ShNew = Worksheets.Add
        ShNew.Name = Item
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
        Rng.AutoFilter
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub

xtremegrump · Nov 24, 2011

Andrew,

Awesome is all I can say. Worked Great.

Could I ask for one more? I would like to copy code from one worksheet to all the other worksheets.

Andrew Poulsom · Nov 24, 2011

Instead of adding a worksheet, copy the worksheet and clear all the cells.

xtremegrump · Nov 24, 2011

I need to add this to all the sheets your macro just created.

Andrew Poulsom · Nov 24, 2011

Start again with this macro:

Code:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim ShNew As Worksheet
    Application.ScreenUpdating = False
'   *** Change Sheet name to suit ***
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A2:A" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("A1:F" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row)
    For Each Item In List
        Sh.Copy after:=Sh.Parent.Worksheets(Sh.Parent.Worksheets.Count)
        Set ShNew = ActiveSheet
        ShNew.Name = Item
        ShNew.Cells.Delete
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
        Rng.AutoFilter
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub

xtremegrump · Nov 24, 2011

I got an error while running:

Run-time error '1004':

Method of 'copy' object'_worksheet failed

Sh.Copy after:=Sh.Parent.Worksheets(Sh.Parent.Worksheets.Count)</pre>

Andrew Poulsom · Nov 24, 2011

How may worksheets are being created? See:

http://support.microsoft.com/kb/210684

pboltonchina · Nov 24, 2011

I've used this on many occasions with great success. Try on a copy of your data in case it's not what you want.

Code:

Option Explicit

Sub ParseItems()
'Jerry Beaucaire  (11/11/2009)
'Based on selected column, data is filtered to individual sheets
'Creates sheets and sorts sheets alphabetically in workbook
'6/10/2010 - added check to abort if only one value in vCol
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim WS As Worksheet, MyArr As Variant, vTitles As String, Oops As Boolean

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
 
'Sheet with data in it
   Set WS = Sheets("Data")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:E1"
   
'Spot bottom row of data
   LR = WS.Cells(WS.Rows.count, vCol).End(xlUp).Row

'Get a temporary list of unique values from column A
    WS.Columns(vCol).SpecialCells(xlConstants).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=WS.Range("EE1"), Unique:=True

'Sort the temporary list
    WS.Columns("EE:EE").Sort Key1:=WS.Range("EE2"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

'Check for more than one value in list
    If WS.Range("EE" & Rows.count).End(xlUp).Row > 2 Then

'Put list into an array for looping
'(values cannot be the result of formulas, must be constants)
        MyArr = Application.WorksheetFunction.Transpose(WS.Range("EE2:EE" _
            & Rows.count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
        WS.Range("EE:EE").Clear

    Else
        WS.Range("EE:EE").Clear
        Oops = True
        GoTo ErrorExit
    End If
    
'Turn on the autofilter, one column only is all that is needed
    WS.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        WS.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
    
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.count)).Name = MyArr(Itm)
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm)).Move After:=Sheets(Sheets.count)
            Sheets(MyArr(Itm)).Cells.Clear
        End If

    'customize this section as needed for copy/paste targets
        WS.Range("A" & WS.Range(vTitles).Resize(1, 1).Row & ":A" & LR) _
            .EntireRow.Copy Sheets(MyArr(Itm) & "").Range("A1")

        
        WS.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm)) _
            .Range("A" & Rows.count).End(xlUp).Row - 1
        Sheets(MyArr(Itm)).Columns.AutoFit
    Next Itm
    
'Cleanup
    WS.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"

ErrorExit:
    If Oops Then MsgBox "Only one value found, aborting parse process..."
    Application.ScreenUpdating = True
End Sub

xtremegrump · Nov 24, 2011

Andy,

Sorry for the delay, I was spending a little time with the family. I tries to add the code from the website and I received the same error. It creates 20936 new tabs.

How to copy entire row to a new sheet based on values in column A

xtremegrump

New Member

Excel Facts

Andrew Poulsom

MrExcel MVP

xtremegrump

New Member

Andrew Poulsom

MrExcel MVP

xtremegrump

New Member

Andrew Poulsom

MrExcel MVP

xtremegrump

New Member

Andrew Poulsom

MrExcel MVP

pboltonchina

Well-known Member

xtremegrump

New Member

Similar threads

Forum statistics

Share this page

How to copy entire row to a new sheet based on values in column A

New Member

Excel Facts

MrExcel MVP

New Member

MrExcel MVP

New Member

MrExcel MVP

New Member

MrExcel MVP

Well-known Member

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock