CODEWITHSUNDEEP
vbaexcel
Jeff Hyman
Jeff Hyman

Reputation: 43

How to copy rows from sheet with multiple entries in same column

I have a sheet from a report that shows something like this:

Agent Name   Acct Number   data     data     data   etc.

Alex         213           data     data     data   etc.

Alex         123           data     data     data   etc.

Alex         4334          data     data     data   etc.

David        23432         data     data     data   etc.

David        2342          data     data     data   etc.

Angel        1111          data     data     data   etc.

Angel        1111          data     data     data   etc.

First, I create a copy of the main template which is stored in a separate sheet. Then I name it to the name of the person who is first in the array.

For z = 2 To jLastRow

    Sheets("Template").copy After:=Sheets(Sheets.Count)
    ActiveSheet.name = MyNames(i) '~~> retrieve from array

    Sheets("From DB Report").Activate

     While MyNames(i) = MyNames(i + 1)

        For Each myrange In Range("a2", Range("a60000").End(xlUp))

                Rows(myrange.Row).EntireRow.copy
                Sheets(MyNames(i)).Cells(myrange.Row * 2, 1).PasteSpecial xlValues
                i = i + 1
                If MyNames(i) <> MyNames(i + 1) Then MyNames(i) = MyNames(i + 1)

                Exit For                        

        Next myrange
    Wend


 Next

What I want to do is then copy the entire row that is selected to the new sheet. Then I want to continue looping while the first person (myNames(i)) is still the same and continue copying rows of that data.

What I need to do is then do the exact same for the rest of the names in the array. I want to end up with a sheet for each name and all the data (by rows) copied over.

I get the copy sheet to work, but I can't seem to get the rows to copy over. Only one row copies. Any help wouild be greatley appreciated!!

UPDATE: My IT department just gave me this set of code, which works on the first name in the list, but it doesn't continue to loop through until it finds the next different name to copy and rename.. 

Sub CopyDataFromReportToIndividualSheets()
    Dim ws As Worksheet
    Set ws = Sheets("From DB Report")
    Dim LastRow As Long
    Dim MyRange As Range

    Worksheets("From DB Report").Activate

    LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row

    ' stop processing if we don't have any data
    If LastRow < 2 Then Exit Sub


    Application.ScreenUpdating = False
    ' SortMasterList LastRow, ws
    CopyDataToSheets LastRow, ws
    ws.Select
    Application.ScreenUpdating = True
End Sub

Sub SortMasterList(LastRow As Long, ws As Worksheet)
    ws.Range("A2:BO" & LastRow).Sort Key1:=ws.Range("A1") ' , Key2:=ws.Range("B1")
End Sub

Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
    Dim rng As Range
    Dim cell As Range
    Dim Series As String
    Dim SeriesStart As Long
    Dim SeriesLast As Long

    Set rng = Range("A2:A" & LastRow)
    SeriesStart = 2
    Series = Range("A" & SeriesStart).Value
    For Each cell In rng
        If cell.Value <> " " Then
            SeriesLast = cell.Row - 1
            CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
            Series = cell.Value
            SeriesStart = cell.Row
        End If
    Next
    ' copy the last series
    SeriesLast = LastRow
    CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series

End Sub

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
                                                        name As String)
    Dim tgt As Worksheet
    Dim MyRange As Range

    If (SheetExists(name)) Then
        MsgBox "Sheet " & name & " already exists. " _
        & "Please delete or move existing sheets before" _
        & " copying data from the Master List.", vbCritical, _
        "Time Series Parser"
        End
    Else
       If Series = " " Then
          End
       End If

    End If

    Worksheets("Template").Activate

    ' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name
    Worksheets("Template").copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.name = name

    Set tgt = Sheets(name)

    ' copy data from src to tgt
    tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" &  Last).Value


End Sub

Function SheetExists(name As String) As Boolean
    Dim ws As Worksheet

    SheetExists = True
    On Error Resume Next
    Set ws = Sheets(name)
    If ws Is Nothing Then
       SheetExists = False
    End If
End Function

This seems to do away with the array of names. If needed, how would I go through the list and populate the array with unique names and then parse the rows to copy?

Thanks again!

Upvotes: 0

Views: 213

Answers (1)

fliedonion
fliedonion

Reputation: 952

The following code you write, Exit For statement will be implemented every time.

            If MyNames(i) <> MyNames(i + 1) Then MyNames(i) = MyNames(i + 1)

            Exit For

If you want to exit for loop only MyNames(i) <> MyNames(i+1), you need write below:

            If MyNames(i) <> MyNames(i + 1) Then 
                MyNames(i) = MyNames(i + 1)
                Exit For
            End If

Updated.

I rewrite two procedure, 

Function SheetExists(name As String) As Boolean
    Dim ws As Variant

    For Each ws In ThisWorkbook.Sheets
        If ws.name = name Then

            SheetExists = True
            Exit Function

        End If
    Next

    SheetExists = False

End Function

You shouldn't rely 'On Error Resume Next' when possible.

Next, CopyDataToSheets procedure, you didn't compare cell.Value and Series. So, Macro try to copy (and create new sheet) in every row.

Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
    Dim allAgentNameCells As Range
    Dim cell As Range
    Dim Series As String
    Dim SeriesStart As Long
    Dim SeriesLast As Long

    Set allAgentNameCells = Range("A2:A" & LastRow)
    SeriesStart = 2
    Series = Range("A" & SeriesStart).Value

    For Each cell In allAgentNameCells

        If cell.Value <> " " And cell.Value <> "" Then
            ' Condition ` And cell.Value <> "" ` added for my testdata. If you don't need this, please remove.

            ' Current Row's Series not SPACE

            If cell.Value <> Series Then
                SeriesLast = cell.Row - 1
                CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
                Series = cell.Value
                SeriesStart = cell.Row
            End If
        End If
    Next

    '' copy the last series
    SeriesLast = LastRow
    CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series

End Sub

In my Excel, this looks like work fine. How about with your data?

Upvotes: 1

Related Questions