Need Code to copy Data to other sheets on condition

[parth007]

Hello Guys,
I need to copy the data to other sheets on conditions
Below is example...
Source Data
Sheet1
CAT: 001
Percent
NA
NA
NA

DOG: 002
Percent
NA
15%
NA

Lion: 003
Percent
NA
NA
NA

Snake: 004
Percent
NA
NA
8.01%
Excel Sheet1 contains above data..
I am asked to Write macro to solve the Below purpose
1)Search "Percent" Column for values.. and return with its Animal Name & number on Sheet2..
Output would be -
DOG: 002
SNAKE: 004
As DOG: 003 & SNAKE: 004 have %value in it.

2) Split the Data on the basis of animal..
Sheet1 will have Cat: 001 Data
Sheet2 will have DOG: 002 Data
Sheet3 will have LION: 003 Data
Sheet4 will have SNAKE: 004 Data
and so
Note there might be n number of animal names in the sheet1

Please help

[mikerickson]

Could you attach a sample workbook showing your lay out and desired result?

[parth007]

Input sheet contains input data
.
.
Now on the data of input sheet below should be the output
.
.
Summary Sheet - Should contain data who have % value in it
Sheet 3, Sheet 4, Sheet 5, Sheet 6 - Contains biffurcated specific animal data.
Sheet attached

[mikerickson]

I think this will do what you want

Sub test()
Dim foundCell As Range, firstFoundRow As Long
Dim animalName As String
Dim lastCell As Range, oneCell As Range
Dim animalRange As Range
Dim AnimalRanges As Collection

Set AnimalRanges = New Collection
With ThisWorkbook.Sheets("Input")
Set lastCell = .Cells(Rows.Count, 1).End(xlUp)

With .Columns(2)
Set foundCell = .Find(what:="?*", after:=.Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious, MatchCase:=False)
firstFoundRow = foundCell.Row

Do
If foundCell.Row > lastCell.Row Then Exit Do
GoSub AddToCollection
Set lastCell = foundCell.Offset(-1, -1)
Set foundCell = .FindPrevious(after:=foundCell)
Loop Until foundCell.Row = 1
End With
End With
GoSub AddToCollection
With Worksheets("Summary").Range("A:B")
.ClearContents
.Cells(1, 1) = "Pct.": .Cells(1, 2) = "animal"
End With
For Each animalRange In AnimalRanges
animalName = Replace(animalRange.Cells(1, 2).Value, ":", vbNullString)
On Error GoTo AddSheet
With ThisWorkbook.Worksheets(animalName)
animalRange.EntireRow.Copy Destination:=.Cells(1, 1)
.Range("A1").Value = .Range("B1").Value
.Range("B1").Value = vbNullString
If WorksheetFunction.Count(.Columns(1)) <> 0 Then
For Each oneCell In .Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers)
Worksheets("Summary").Range("A65536").End(xlUp).Offset(1, 0).Value = oneCell.Value
Worksheets("Summary").Range("A65536").End(xlUp).Offset(0, 1).Value = .Range("A1").Value
Next oneCell
End If
End With
On Error GoTo 0
Next animalRange
With ThisWorkbook.Worksheets("summary")
With Range(.Cells(1, 2), .Cells(Rows.Count, 1).End(xlUp))
.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
End With
End With
Exit Sub
AddToCollection:
animalName = foundCell.Value
If animalName <> vbNullString Then
On Error Resume Next
AnimalRanges.Add Item:=Range(lastCell, foundCell), Key:=animalName
On Error GoTo 0
End If
Return
AddSheet:
If Err = 9 Then
Err.Clear
With ThisWorkbook
.Sheets.Add(after:=.Sheets(.Sheets.Count)).Name = animalName
End With
Resume
Else
MsgBox Err & vbCr & Error
End If
End Sub

[parth007]

I am done with the automation... Today i received one last new task..

One client needs summary page to get filled as per the Input sheet data.. data is little bit different..
i have attached the sample file..

Please help me here.. i am trying to build code accordingly but i am not able to

[parth007]

Thanks all.. i made the automation complete... thanks for all help i got here :bow::bow: