Copy Row Based on a Condition to Another Sheet

Question

I've been looking on this website for an answer but can't find anything relevant and was wondering if someone could help please.

I have an excel document.

Sheet 1 contains a list of extension numbers, eg, EXT 1202. EXT 1203, EXT 1204.

Sheet 2 is called EXT 1202. Sheet 3 is called EXT 1203. sheet 4 is called EXT 1204 and so on.

I need to be able to run a macro that will scan Sheet 1 for all the rows that contain the word "EXT 1202" and copy it into the sheet that's called EXT 1202 which will then copy all the rows from Sheet 1 that contain the word EXT 1203 and copy it into the sheet that's called 1203.

PS I'm working on Microsoft Excel 2010 which basically helps me to find out which extension numbers made which calls and allows me to charge those people for personal calls. I like having the data for each extension number on a separate sheet because then I can literally print each sheet if that person wanted a copy.

I would like for the code to be able to specify when it pastes all rows containing the word, say EXT 1202. Would it be possible to specify it to paste it into the sheet called "EXT 1202" but say starting in a specific row, say row 100? Rows 1-99 contain text which I don't want to be overwritten. Is it possible to automatically change the font of the data that is being copied and pasted?

I know this is difficult. I am hoping someone out there can take up the challenge and perhaps give me a code for this pretty please, I'm just a dumb accountant :-S so this would be good. Many thanks in advance, Michelle

Answer 1

Here's some quick code I tossed together (commented so you can modify if need be). This assumes that your data starts in cell A2 on Sheet1, and that the extension numbers (1203 / 1204 in this example) are located in column A. It will grab the rows and paste them on the individual sheets (the sheets must be set up in advance), and it will skip rows that have data. Rows that do NOT correspond to one of the pre-defined extension numbers will be highlighted yellow. Hope this helps!

Sub Phone_Numbers()

    'Start on the main first sheet, cell A2
    Sheets("Sheet1").Select
    Range("A2").Select

    'Loop while activecell is not blank (goes down the column)
    Do While ActiveCell <> ""
        'You need to create these for every possible extension
        '  Also, create individual worksheets for each
        If InStr(1, ActiveCell, "1203", 1) <> 0 Then
            ActiveCell.EntireRow.Copy
            Sheets("Ext 1203").Select
            Range("A2").Select

        ElseIf InStr(1, ActiveCell, "1204", 1) <> 0 Then
            ActiveCell.EntireRow.Copy
            Sheets("Ext 1204").Select
            Range("A2").Select

        Else
            'If it's not an extension you have specified, it highlites the cell
            ActiveCell.Interior.ColorIndex = 6
            GoTo SKIPPING
        End If

        Range("A2").Select
        'Loops down until there's an open
        Do While ActiveCell <> ""
            ActiveCell.Offset(1, 0).Select
        Loop

        ActiveSheet.Paste

        'Go back to the starting sheet & iterate to the next row
        Sheets("Sheet1").Select
SKIPPING:
        ActiveCell.Offset(1, 0).Select
    Loop

End Sub