excel macro to filter and paste to sheet

Microsoft Microsoft excel 2007 (pc)
March 17, 2010 at 11:28:50
Specs: Windows Vista
I am trying move data from Sheet1 to new sheets based on values in column A (a person's name). My data has an indefinite number of rows, but each row has a name in column A. I would like a new sheet for each name, and the name of the sheet to match the name in column A. The sheet should contain all rows from Sheet1 with a particular name, then sort the rows based on another column (date), sorted by earliest to latest date.

See More: excel macro to filter and paste to sheet

Report •

#1
March 17, 2010 at 15:58:39
My mistake...this is the first time I have used computing.net and missed the salutation and closing...
Yes, I am requesting help and would be very thankful for any assistance.
Thanks again!

Report •

#2
March 18, 2010 at 05:51:58
Hi,

Here is a macro that will take the names in column A in Worksheet 'Sheet1' - starting at cell A2 - (assumes one header row)
If names start at a different row or the sheet has a different name, change this line

'set start of data (range containing names for worksheets)
Set rngStart = Worksheets("Sheet1").Range("A2")

As each name is found, a test is carried out for the main non-valid worksheet names - it is not a comprehensive test. If a name is found that contains /\*?[ or ] a warning message is displayed and the name is then ignored. Any rows starting with an empty cell in column A are ignored (no warning message)

Due to the way the macro determines the last row in column A, all cells in column A below the last name must be empty.

Worksheet names are created if that sheet name does not exist. All rows are copied to the worksheet with the same name.

The copy is done as a PasteSpecial
You can change the PasteSpecial type in this line, if required:

rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)

Note that if you re-run the macro the data on the source worksheet (Sheet1) will be appended to the existing data on the various named sheets.

To run the macro, I suggest you add a button to your source worksheet
From the Ribbon select Developer (If it's not visible go to the Office Button, select Excel options at the bottom and select the Popular tab and check the 'Show Developer tab in the Ribbon' box)

In Developer - Controls select Insert and choose the button icon.
Draw the button on the worksheet
In the 'Assign Macro' dialog box select 'New'

In the code window that opens enter this:

Option Explicit

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names for worksheets)
Set rngStart = Worksheets("Sheet1").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet1").Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with names
For Each rngCell In Range(rngStart, rngEnd)
    'get name
    strWsName = rngCell.Text
    'exclude the main inelligible names
    If strWsName <> "" And InStr(1, strWsName, "/") = 0 _
            And InStr(1, strWsName, "\") = 0 And InStr(1, strWsName, "?") = 0 _
            And InStr(1, strWsName, "*") = 0 And InStr(1, strWsName, "[") = 0 _
            And InStr(1, strWsName, "]") = 0 Then
        'test if worksheet exists
        On Error Resume Next
        If Worksheets(strWsName) Is Nothing Then
            'worksheet does not exist, so create & name it
            On Error GoTo ErrHnd
            'create new sheet
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            'name new sheet
            Worksheets(Worksheets.Count).Name = strWsName
        End If
        'if name was valid for a worksheet, copy row to that named sheet
        'find empty row after end of destination data
        Set rngDestEnd = Worksheets(strWsName). _
                Range("A" & CStr(Application.Rows.Count)).End(xlUp).Offset(1, 0)
        rngCell.EntireRow.Copy
        rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
        Else
        'name not valid - warn user - but ignore empty cells
        If strWsName <> "" Then
            MsgBox strWsName & " is not a valid worksheet name", vbOKOnly, _
                    "Worksheet Names"
        End If
    End If
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
End Sub

Note that Sub Button1_Click() and End sub will already be present, so don't duplicate them. Option explicit goes before Sub Button1_Click().

Click Save from the Visual Basic Menu.

Alt+f11 takes you back to the main Excel window.

Right click the button and Edit the name to something meaningful

As Macros cannot be undone with the Undo button, test this macro on a copy of your data. Always make a backup of your Workbook before running this macro. This code has only been tested on sample data, and it has not been tested in your environment, so test it on copies of your data to ensure that it works 'as expected'

After selecting any cell, the new command button should now respond to a click and run the macro.

If this works, a sort can be added. You will need to say what column the date information is in.

Also can you confirm that the dates are true Excel dates.
Do this in a cell with a date.
Right-click, select Format Cells... then select Numbers tab and select Number with two decimal places.
If the date now shows as a number such as 40000 (40000 was 6 July 2009), then they are in excel date format. If they stay as a date, then Excel has not recognized them as dates. This can affect how sorting works.

Regards


Report •

#3
March 19, 2010 at 22:56:55
Humar,
Your macro works very well and your additional comments are
very informative; thank you!
I am working on the date sort and changing any dates which
occur in the past to red. Also, it is nice of you to add the
button, screen updating and error handling features as well. I
appreciate your help.

Report •

Related Solutions

#4
March 20, 2010 at 08:21:08
Hi,

Here is an extension of the macro to include a sort - by date and dates before today are formatted in red font.

For my test, I had the dates in column B, but you can change this in one line of code:

'date column letter - change as required
strDateCol = "B"

The macro excludes the source worksheet from the sorting and date font color change.
If you want to exclude any other worksheets, change this line from

    'exclude the source worksheet
    If wsEach.Name <> strSourceWsName Then
to something like this:
    If wsEach.Name <> strSourceWsName  And wsEach.Name <> "MySheetToExclude"  Then

Macro with Sort:

Option Explicit

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String
Dim wsEach As Worksheet
Dim strSourceWsName As String
Dim strDateCol As String
Dim rngDateStart As Range
Dim rngDateEnd As Range

On Error GoTo ErrHnd

'date column letter - change as required
strDateCol = "B"

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'get this worksheet's name (the source worksheet)
strSourceWsName = ActiveSheet.Name

'set start of data (range containing names for worksheets)
Set rngStart = Worksheets("Sheet1").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet1").Range("A" & CStr(Application.Rows.Count)) _
            .End(xlUp)

'Loop through all cells with names
For Each rngCell In Range(rngStart, rngEnd)
    'get name
    strWsName = rngCell.Text
    'exclude the main inelligible names
    If strWsName <> "" And InStr(1, strWsName, "/") = 0 _
            And InStr(1, strWsName, "\") = 0 And InStr(1, strWsName, "?") = 0 _
            And InStr(1, strWsName, "*") = 0 And InStr(1, strWsName, "[") = 0 _
            And InStr(1, strWsName, "]") = 0 Then
        'test if worksheet exists
        On Error Resume Next
        If Worksheets(strWsName) Is Nothing Then
            'worksheet does not exist, so create & name it
            On Error GoTo ErrHnd
            'create new sheet
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            'name new sheet
            Worksheets(Worksheets.Count).Name = strWsName
        End If
        'if name was valid for a worksheet, copy row to that named sheet
        'find empty row after end of destination data
        Set rngDestEnd = Worksheets(strWsName). _
                Range("A" & CStr(Application.Rows.Count)).End(xlUp).Offset(1, 0)
        rngCell.EntireRow.Copy
        rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
        Else
        'name not valid - warn user - but ignore empty cells
        If strWsName <> "" Then
            MsgBox strWsName & " is not a valid worksheet name", vbOKOnly, _
                    "Worksheet Names"
        End If
    End If
Next rngCell

'clear copy marquee
Application.CutCopyMode = False

'go through each worksheet, except the source worksheet
For Each wsEach In ActiveWorkbook.Worksheets()
    'exclude the source worksheet
    If wsEach.Name <> strSourceWsName Then
        'sort the rows by the date column

        'Sort - assumes one header row & uses current region
        wsEach.Range("A1").Sort _
                Key1:=wsEach.Range(strDateCol & "1"), _
                Order1:=xlAscending, _
                Header:=xlYes

        'now change text color for all dates earlier than today
        'set start of date column
        Set rngDateStart = wsEach.Range(strDateCol & "2")
        'set end of date column
        Set rngDateEnd = wsEach.Range(strDateCol & CStr(Application.Rows.Count)) _
                        .End(xlUp)
        For Each rngCell In wsEach.Range(rngDateStart, rngDateEnd)
            'use integers to exclude any time information stored with dates
            If Int(rngCell.Value) < Int(Now) Then
                rngCell.Font.Color = RGB(200, 0, 20)
                Else
                rngCell.Font.Color = RGB(0, 0, 0)
            End If
        Next rngCell
    End If
Next wsEach

'restore screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
End Sub

Regards


Report •

#5
March 23, 2010 at 15:56:49
Humar,
Once again, your help has been invaluable. Thank you very much!!!

Report •

#6
March 30, 2010 at 15:41:25
Humar,
I was wondering if you could help me out with the date sort a bit more. I also would like to place any rows with no data in the date column (no date) to go above the rows that have dates in them, which are still sorted by earliest to latest and red if overdue.
Thank you!

Report •

Ask Question