Excel Macro, Filtering, Copy data, Rename

July 22, 2010 at 10:41:13
Specs: Windows XP
Hi, I would like to thanks in advance for someone who help me.

The raw data on my excel file is a list of pilots taking different training courses. I would like to filter in terms of the name of each course (column F - Description), and copy the filtered data to new sheet. Then rename the new sheet created based on the name of the course.

So, if there are 15 courses, there will be 15 new sheets created.

The course number may be increased or decreased in the future.

Is there anyway for a macro to do that?

Here is the sample data
Col1 Col 2 Col3 Col4 Col5 Col6 Col7 Col8
RECRU EMPLOYEE_NAME EMPLOYEE_ID GROUP_TYPE REG_QUAL DESCRIPTION LAST COMPLETED NEXT
XXX XX 100 XXX XXX Abc XXX XXX
XXX XX 100 XXX XXX Abc XXX XXX
XXX XX 100 XXX XXX Def XXX XXX
XXX XX 100 XXX XXX Gih XXX XXX


See More: Excel Macro, Filtering, Copy data, Rename

Report •


#1
July 29, 2010 at 06:22:45
Hi,

Here is a macro which will create new worksheets for each course and will copy the relevant records to the appropriate Course worksheet.

The macro starts with a pop-up asking if you want to run this to just add new data, or to re-run the whole thing from the start - appropriate if you have updated source data that has already been copied to individual course worksheets.

The macro identifies course worksheets by using the word "Course" and adding the text from column F to it.
The Word "Course" allows the macro to identify worksheets that contain Course data.

When the macro has run, it puts the word "Copied" at the end of the data that has been copied.
Add new data to rows following "Copied"
When the data is updated, the word "Copied" will automatically be moved to the end of the data.

I suggest that this macro is attached to a button embedded on the worksheet containing your source data.
You haven't said what version of Excel you use, so I have included instructions for Excel 2003.
Excel 2007 or later is slightly different, in terms of adding the button, and the name of the button inside Visual Basic.

If you have Excel 2007 or Excel 2010 and need more help, please ask.
(Note: VB macros don't work in Excel 2008 for Mac)

On the source data Worksheet, create a command button from the Control Toolbox toolbar.
(If this isn't visible, right click on an existing toolbar and check the Control Toolbox).
Select the button Icon and draw a button
Right-click the button and select Command Button - Edit and change the name to 'Transfer' or something appropriate.
Right-click the button again and select View Code
In the code window that opens enter this:

Option Explicit

Private Sub CommandButton1_Click()

Dim strResp As String
Dim wksEach As Worksheet
Dim strThisWks As String
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim strCourse As String
Dim rngSearch As Range
Dim rngFind As Range

On Error GoTo ErrHnd

'ask if this is a regular Add data or a full Update
strResp = MsgBox("Click 'Yes' to add new data to existing data" & vbCrLf _
        & "Click 'No' to update all data" & vbCrLf _
        & "Click 'Cancel' to quit without any update", vbYesNoCancel, _
        "Add new data or Update all data")

'stop screen updating to increase speed
Application.ScreenUpdating = False

'save the name of this worksheet
strThisWks = ActiveSheet.Name

'select options
'if Cancel - quit macro
If strResp = vbCancel Then Exit Sub

'if No then delete all 'Course' worksheets
If strResp = vbNo Then
    'loop through all worksheets
    For Each wksEach In ActiveWorkbook.Worksheets()
        'test name - not this sheet & must start with "Course"
        If wksEach.Name <> strThisWks And _
                    Left(wksEach.Name, 6) = "Course" Then
              'name meets criteria - so delete it - without warning
              Application.DisplayAlerts = False
              wksEach.Delete
              Application.DisplayAlerts = True
        End If
    Next wksEach
    'delete row containing 'Copied' (if any)
    With Worksheets(strThisWks)
        Set rngSearch = Range("A2:A" & CStr(Application.Rows.Count))
        Set rngFind = rngSearch.Find("Copied", LookIn:=xlValues)
        'test if 'Copied' found
        If Not rngFind Is Nothing Then
            'delete the row containing 'Copied'
            rngFind.EntireRow.Delete
        End If
    End With
End If

With Worksheets(strThisWks)
    'set start as row after cell with 'Copied' in it
    'if 'Copied' not found use A2 i.e., after heading row in column A
    Set rngSearch = _
            Range("A2", . _
            Range("A" & CStr(Application.Rows.Count)).End(xlUp))
    Set rngFind = rngSearch.Find("Copied", LookIn:=xlValues)

    If rngFind Is Nothing Then
        'Copied not found - so start at A2
        Set rngStart = .Range("A2")
        'set response string to 'No'
        strResp = vbNo
        Else
        'Copied found
        strResp = vbYes
        'set start to row after 'Copied'
        Set rngStart = rngFind.Offset(1, 0)
        'if nothing after 'Copied' just quit
        If rngFind.Offset(1, 0).Value = "" Then
            'no new data
            MsgBox "No new data found" & vbCrLf & "No update performed"
            Exit Sub
        End If
        'delete the row containing 'Copied'
        rngFind.EntireRow.Delete
    End If
    
    'set end - last used row in column A
    Set rngEnd = .Range("A" & CStr(Application.Rows.Count)).End(xlUp)
    
    'loop through cells in column A
    For Each rngCell In Range(rngStart, rngEnd)
    'Extract Course name to use as Sheet name (from Col. F)
      strCourse = "Course" & rngCell.Offset(0, 5).Text
        'test if tab exists
        On Error Resume Next
        If Not Worksheets(strCourse).Name <> "" Then
            On Error GoTo ErrHnd
            'No worksheet of this name - so create one
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = strCourse
            'copy header
            .Range("A1").EntireRow.Copy
            'paste header data
            Worksheets(strCourse).Range("A1").PasteSpecial Paste:=xlAll
            'paste column widths
            Worksheets(strCourse).Range("A1").PasteSpecial _
                        Paste:=xlPasteColumnWidths
            'set row height
            Worksheets(strCourse).Rows(1).RowHeight = .Range("A1").RowHeight
            'copy & paste first row of data
            rngCell.EntireRow.Copy _
                        Destination:=Worksheets(strCourse).Range("A2")
            Else
            On Error GoTo ErrHnd
            'worksheet exists
            'copy row to end of used range
            rngCell.EntireRow.Copy Destination:=Worksheets(strCourse). _
                    Range("A" & CStr(Application.Rows.Count)). _
                    End(xlUp).Offset(1, 0)
        End If
    Next rngCell
    'flag end of copied data (in column A)
    rngEnd.Offset(1, 0).Value = "Copied"
End With

'restore screen updating
Application.ScreenUpdating = True
Exit Sub

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

Note that Private Sub CommandButton1_Click() and End sub will already be present, so don't duplicate them. Option Explicit goes before Private Sub CommandButton1_Click().
Some lines of code have been split onto two lines for ease of viewing, using the line continuation character "_". This should work 'as is' just copy and paste, or you could remove the "_" and bring the code back to one line.

Click Save from the Visual Basic Menu.

Alt+f11 takes you back to the main Excel window.
Exit design mode (first icon on the Controls Toolbox toolbar).

As changes made by 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 limited 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'

Click the 'Transfer' button to run the macro.

Regards


Report •
Related Solutions


Ask Question