Macro for sorting & moving data into new tabs

Microsoft Excel 2007
December 10, 2009 at 13:04:41
Specs: Windows XP
I need some macro code that can sort a large amount of data into multiple tabs. Here's an example:
# name $ description
1 new $45 kdsjfsdjf
2 blank $55 kfjsdkks
3 new2 $33 kjdfkjdf
4 blank $67 kfjklsjfjk

I would need all the blanks (row's 2 and 4) copied together into a tab called blanks. All the new2 (row 3) copied together into a tab called new. etc...

Could you please help! Thanks

See More: Macro for sorting & moving data into new tabs

Report •

December 10, 2009 at 14:58:18
Do you know how to write/modify VBA code?

This thread discusses a similar requirement.

The code offered in that thread determines the names for the new sheets, creates them and then copies the data to the appropriate sheets.

Your requirements are simpler than outlined in that thread, meaning that a modification (read: simplification) of the code in that thread should get you the results you need.

Come on back if you need any more help.

Report •

December 10, 2009 at 15:03:12

Here is a macro that I hope does what you want.

Using your sample data in a workbook with a single worksheet named "Source",
The macro created three new worksheets (new, new2 & blank)
new contained item 1
new2 contained item 3
and blank contained items 2 and 4.

Obviously this was a limited test of the code.

Here is the code:

Public Sub MoveToTab()
Dim rngRow As Range
Dim rngCell As Range

On Error GoTo ErrHnd

'use All used rows except first, in 'Source' Worksheet
With Worksheets("Source").UsedRange.Offset(1, 0) _
    .Resize(Worksheets("Source").UsedRange.Rows.Count - 1, _
    'loop through all rows
    For Each rngRow In .Rows
        'test if tab exists
        On Error Resume Next
        If Not Worksheets(rngRow.Range("B1").Text).Name <> "" Then
            On Error GoTo ErrHnd
            'No Tab of this name - so create one and copy row
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = rngRow.Range("B1").Text
            rngRow.Copy Destination:=Worksheets(rngRow.Range("B1").Text).Range("A1")
            On Error GoTo ErrHnd
            'worksheet exists
            'copy row to end of used range
            rngRow.Copy Destination:=Worksheets(rngRow.Range("B1").Text).Range("A1") _
                .Offset(Worksheets(rngRow.Range("B1").Text).UsedRange.Rows.Count, 0)
        End If
    Next rngRow
End With

Exit Sub

'error handler
End Sub
Note that some lines are split onto two or three lines, using the line continuation "_" character, but it should work when copied and pasted to a standard module.

Please note that there is NO undo with a macro. Please test with sample data and always make backups before running it on real data.

Hope this helps.


Report •

Related Solutions

Ask Question