Copying Range of Rows to New Sheet

[snsllvn]

I have an Excel 2003 workbook with a sheet that has multiple data entries entered as groups of 8 rows and multiple columns. Each data entry corresponds with a real world location (Houston, St. Louis, or Spring House) and is denoted in one of the 8 rows by one of the following strings: HOU, STL, SPH.

I want to separate the data for each location into it's own sheet. The 3 letter string is not always in the same row, and one 8 row data entries aren't always consecutive. However, the first row of each data entry always contains the string "Project Management".

My basic strategy is to search for "Project Management", get the row that contains that string, then search the following 8 rows for one of the 3 strings above. Then, copy the data to the corresponding sheet depending on which string was found.

Here is the function I am using to return the row containing "Project Management":

Private Function pFindDataEntry(sText As Variant) As Variant

    Dim lResult As Long, rRowPos As Range

    Set rRowPos = Cells.Find(What:=sText, After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

    If Not rRowPos Is Nothing Then lResult = rRowPos.Row

    pFindDataEntry = lResult

    Set rRowPos = Nothing
    
End Function

Here is the code I'm using to search within the 8 row range and determine if it has "HOU", "STL" or "SPH":

Private Function pFindLocation(sText As Variant) As Variant

    Dim lRowStart As Long, rDataEntry As Range, rLocation As Range, sResult As Variant

    lRowStart = pFindDataEntry("project management")

    Set rDataEntry = Rows(lRowStart & ":" & lRowStart + 7)
    
    Set rLocation = rDataEntry.Find(What:=sText, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
    If Not rLocation Is Nothing Then sResult = rLocation.Value Else sResult = "Nothing"

    pFindLocation = sResult
    
    Set rLocation = Nothing
    
    'this activates the location cell so it will find the next one in the sheet next time it is run
    If Not sResult = "Nothing" Then _
        rDataEntry.Find(What:=sText, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
    On Error Resume Next
    
End Function

Both of these functions work. Now I'm trying to write the code to transfer the group of 8 rows in the data entry to a new sheet with the location name. Here is the code I'm using for that:

Public Sub CopyEntryNewSheet(sText As Variant)

    Dim lRowStart As Long, rDataEntry As Range, sLocation As Variant
    
    lRowStart = pFindDataEntry("project management")

    'range that contains 8 row data entry
    Set rDataEntry = Rows(lRowStart & ":" & lRowStart + 7)
          
    With Worksheets("Project Hours")

    'check if sheet exists for this location
    If Not Worksheets(sText).Name <> "" Then
        'No worksheet for this location - create one and copy rows
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Name = sText
        rDataEntry.EntireRow.Copy Destination:=Worksheets(sText).Range("A1")
    Else
        'worksheet exists
        'copy rows to end of used range
        rDataEntry.EntireRow.Copy Destination:=Worksheets(sText).Range("A1") _
        .Offset(Worksheets(sText).UsedRange.Rows.Count, 0)
    End If

    End With

End Sub

I get a "Subscript out of range" error on the following line:
If Not Worksheets(sText).Name <> "" Then

Also, I will need to run this code in a loop to go through a worksheet of data entries, any suggestions on how I might do this efficiently?

Thanks.

 

[snsllvn]

I resolved this by adding "On Error Resume Next".

 

[Norie]

Are you sure it's actually resolved by adding that?

I'd double check - you might not be getting any errors but the code might not actually be doing what you want/expect it to.

You also mentioned a loop but I don't see one.

 

[snsllvn]

The code to copy the rows works, it will copy to a new worksheet now, I've tested that much.

Here is the code for the loop I'm trying to run it all in, but I'm getting an object required error on the first line:

Sub SeparateLocations()

Do While Not pFindDataEntry("project management") Is Nothing
    If pFindLocation("HOU") = "HOU" Then CopyEntryNewSheet ("HOU") _
    Else: If pFindLocation("SPH") = "SPH" Then CopyEntryNewSheet ("SPH") _
    Else: If pFindLocation("STL") = "STL" Then CopyEntryNewSheet ("STL") _
    Else: If pFindLocation("Nothing") = "Nothing" Then CopyEntryNewSheet ("Nothing")
Exit Do
Loop


    
End Sub

 

[snsllvn]

Here are the updated functions I am using:

The is the function to find the beginning of the data entry:

Private Function pFindDataEntry(sText As Variant) As Variant

    Dim lResult As Long, rRowPos As Range

    Set rRowPos = Cells.Find(What:=sText, After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

    If Not rRowPos Is Nothing Then
        lResult = rRowPos.Row
        pFindDataEntry = lResult
    Else
        pFindDataEntry = "Nothing"
    End If
                
    Set rRowPos = Nothing
    
End Function

And here is the code I'm trying to use for the loop:

Sub SeparateLocations()

    Dim vDataEntry As String
        
    Application.ScreenUpdating = False
    
    vDataEntry = pFindDataEntry("project management")

    Do While Not vDataEntry = "Nothing"
        If pFindLocation("HOU") = "HOU" Then CopyEntryNewSheet ("HOU") _
        Else: If pFindLocation("SPH") = "SPH" Then CopyEntryNewSheet ("SPH") _
        Else: If pFindLocation("STL") = "STL" Then CopyEntryNewSheet ("STL") _
        Else: If pFindLocation("Nothing") = "Nothing" Then CopyEntryNewSheet ("Nothing")
             
        vDataEntry = pFindDataEntry("project management")
        
        'this activates the start of the data entry so it will find the next one in the sheet next time it is run
        Cells.Find(What:="project management", After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
      
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

The problem I'm running into now is my strategy for breaking out of the loop isn't working. I thought the find function would return a Nothing value if it can't find another "project management" when it gets to the end of the file, but it starts searching from the beginning of the file again.

Any suggestions for how to break out of the loop?

 

[Norie]

Not sure about breaking out of the code, but then again I'm not sure about your code.

Why don't you move the Find into the main code and actually use the result from it rather than using a function?

In the find function you are using Cells every time for where to look.

That means you are searching for the value in every cell on the worksheet.

Can I ask what the relevance of the 8 rows and Project Management?

Don't you just want to move each entry to the appropriate sheet based on a value in a particular column (HOU, SPH, etc) and whether or not Project Management
appears in the same row?

Perhaps if you posted some sample data it'll help make things clearer.