Excel: Test each value in column A and copy matching values into new workbooks in Excel 2003/XP/2000/97

Question: In Excel 2003/XP/2000/97, how can I write an Excel macro that needs to compare data in Cell A2 to A3 and so on until it doesn't find a match? So if there were 100 rows in the sheet and the data in column A for the first 50 were equal, but A51 contained a different value and you wanted to copy the data from A2 through A50 into a new workbook.

Then the macro would continue comparing the values in column A starting from Cell A51 until a different value was encountered. It would then copy the data into another new workbook, and so on...until all values had been evaluated in column A.

Answer: You should be able to create a macro that tests each value in column A and checks for differences.

Let's take a look at an example.

Download Excel spreadsheet (as demonstrated below)

In our spreadsheet, we've created a button on the Data sheet called "Copy Data". When the user clicks on this button, a macro called CopyData will run. This macro will analyze each value in column A to search for a different value.

When a different value is found in column A on the Data sheet, the macro will then copy the values in columns A through D up to the different value, and paste into a new workbook.

So in this example, it copies all rows until it reaches the Microsoft value in cell A8 (on the Data sheet) and pastes these values to a new workbook.

The macro then goes back to column A on the Data sheet and continues analyzing the value starting from cell A8.

It then creates another workbook and copies the Microsoft data into this new workbook.

When the macro has completed, the above message box will appear. It identifies the number of new workbooks that were created and where to find them.

You can view the new workbooks by selecting it under the Window menu. In this example, we've created Book1 and Book2.

Book1 displays the data for Tech on the Net.

Book2 displays the data for Microsoft.

You can press Alt-F11 to view the VBA code.

Macro Code:

The macro code looks like this:

Sub CopyData()

    Dim LMainWB As String
    Dim LNewWB As String
    Dim LRow As Integer
    Dim LContinue As Boolean

    Dim LColAMaster As String
    Dim LColATest As String

    Dim LWBCount As Integer
    Dim LMsg As String

    'Retrieve name of the workbook that contains the data
    LMainWB = ActiveWorkbook.Name

    'Initialize variables
    LContinue = True
    LRow = 2
    LWBCount = 0

    'Start comparing with cell A2
    LColAMaster = "A2"

    'Loop through all column A values until a blank cell is found
    While LContinue = True

        LRow = LRow + 1
        LColATest = "A" & CStr(LRow)

        'Found a blank cell, do not continue
        If Len(Range(LColATest).Value) = 0 Then
            LContinue = False
        End If

        'Found occurrence that did not match, copy data to new sheet
        If Range(LColAMaster).Value <> Range(LColATest).Value Then

            'Copy headings
            Range("A1:D1").Select
            Selection.Copy

            'Add new workbook and paste headings into new workbook
            Workbooks.Add
            LNewWB = ActiveWorkbook.Name
            ActiveSheet.Paste
            Range("A1").Select

            'Copy data from columns A - D
            Windows(LMainWB).Activate
            Range(LColAMaster & ":D" & CStr(LRow - 1)).Select
            Selection.Copy

            'Paste results
            Windows(LNewWB).Activate
            Range("A2").Select
            ActiveSheet.Paste
            Range("A1").Select

            'Go back to Main sheet and continue where left off
            Windows(LMainWB).Activate
            LColAMaster = "A" & CStr(LRow)

            'Keep track of the number of workbooks that have been created
            LWBCount = LWBCount + 1

        End If

    Wend

    Range("A1").Select
    Application.CutCopyMode = False

    LMsg = "Copy has completed."
    LMsg = LMsg & Chr(10) & "There are " & LWBCount & " new workbooks that you need to save."
    LMsg = LMsg & Chr(10) & "You can view the new workbooks under the Windows menu."

    MsgBox LMsg

End Sub