Split the data into 2 sheets using VBA

jmkbrown used Ask the Experts™
Each day I will be getting a spreadsheet that will need to be split into to 2.  I will know where the data needs to be split by finding "HHP0" in column A.  I will not want to copy of the first 2 rows.  The data above the row that contains "HHP0" will go to one sheet, while the data below "HHP0" will go to another sheet.  I am able to find the data and select all of the information above that row, but I don't know how to exclude the top 2 rows.

Thank you in advance,
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Most Valuable Expert 2012
Top Expert 2012
As requested.  I've created a sample dataset for testing and included in the attached.

Here's the code:
Option Explicit

Sub splitData()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksSplit1 As Worksheet
Dim wksSplit2 As Worksheet
Dim r As Range
Dim rng As Range
Dim rFind As Range
Dim lastCol As Long
Dim lastRow As Long

    Application.ScreenUpdating = False
    Set wkb = ThisWorkbook
    Set wks = wkb.Worksheets("DataSheet")
    ' Create output tabs Split1 and Split2 if they don't already exist
    On Error Resume Next
    Set wksSplit1 = wkb.Worksheets("Split1")
    If Err.Number <> 0 Then
        Set wksSplit1 = wkb.Worksheets.Add(after:=wkb.Worksheets(wkb.Worksheets.Count))
        wksSplit1.Name = "Split1"
    End If
    Set wksSplit2 = wkb.Worksheets("Split2")
    If Err.Number <> 0 Then
        Set wksSplit2 = wkb.Worksheets.Add(after:=wkb.Worksheets(wkb.Worksheets.Count))
        wksSplit2.Name = "Split2"
    End If
    On Error GoTo 0
    ' Clear output tabs
    lastCol = wks.Cells(1, wks.Columns.Count).End(xlToLeft).Column
    lastRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row
    'Find term HHP0 in Column A to define top half for split 1
    Set rFind = wks.Range("A:A").Find(what:="HHP0", LookIn:=xlValues, lookat:=xlPart)
    If Not rFind Is Nothing Then 'find HHP0!
        'copy from row 3 to HHP0 row & paste in Split1
        wks.Range("A3", wks.Cells(rFind.Row, lastCol)).Copy
        Application.CutCopyMode = False
        'copy from HHP0 + 1 row to bottom of dataset & paste in Split2
        wks.Range(wks.Cells(rFind.Row + 1, 1), wks.Cells(lastRow, lastCol)).Copy
        Application.CutCopyMode = False
        MsgBox "Process Complete!"
        MsgBox "HHP0 term was NOT found in column A of DataSheet tab", vbCritical
    End If
    Application.ScreenUpdating = True
End Sub

Open in new window

See attached.



This worked perfectly!  Thank you very much!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial