Sealecting rows by value and copying to new sheet

I'm trying to select entire rows of data based on specific values in a column and then paste those rows to a new worksheet.

This code below loops 10 times and creates 10 new sheets. Any chance someone could explain some of the code to me and help me adapt it to suit my situation?:

Data will be in sheet 1 ("Data List"). I want search down the rows and if the value in column 2 is "1" copy that row to the sheet named "Heat 1", if the value is "2" then copy that row intt the sheet "Heat 2", etc.

Sub FindandCopyRows() 
    Dim Data As Variant 
    Dim DataFound() As Variant 
    Dim iValue As Integer 
    Dim j As Long 
    Dim i As Integer 
     
    Application. ScreenUpdating = False 
    For iValue = 1 To 10 
        With Worksheets("Main") 'change  name as needed
            .Select 
            Data = .UsedRange.Value 
        End With 
        Redim DataFound(1 To UBound(Data)) 
        For j = 1 To UBound(Data, 1) 
            On  Error Resume Next 
            If Data(j, 2) = iValue Then DataFound(j) = 1 
        Next j 
        For j = 1 To UBound(Data, 1) 
            If Not DataFound(j) = 1 Then 
                For i = 1 To UBound(Data, 2) 
                    Data(j, i) = "" 
                Next i 
            End If 
        Next j 
         ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count) 
        With ActiveSheet 
            .Name = "Sheet " & iValue 'change name as needed
            .Range(Cells(1, 1), Cells(UBound(Data, 1), UBound(Data, 2))).Select 
            Selection = Data 
            Selection.Sort Range("a1") 
            .Range("a1").Select 
        End With 
    Next iValue 
End Sub

Any help would be much appreciated.

Cross-post: http://www.ozgrid.com/forum/showthre...169#post429169

Hi,

Ended up rewriting code rather than go through what was already there.

Sub FindAndCopyRows()

Dim DataListLastRow As Integer
Dim Number As Integer
Dim DataList As Worksheet
Dim i As Integer
Dim j As Integer

Set DataList = Worksheets("Data List")
DataListLastRow = DataList.Cells(65536, 2).End(xlUp).Row


For i = 1 To DataListLastRow
    Number = DataList.Cells(i, 2)
    
    For j = 2 To Worksheets.Count
        If Worksheets(j).Name = "Heat_" & Number Then GoTo InsertHeat
    Next j
        
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "Heat_" & Number

InsertHeat:
    
    DataList.Select
    
    With Worksheets("Heat_" & Number)
        DataList.Rows(i).Copy
        Paste (.Cells(65536, 1).End(xlUp).Offset(1, 0))
    End With
    
Next i

End Sub

This will work it's way down column B and copy the contents of the entire row to a new sheet called "Heat_x" depending on the value in column B.
I advise you make sure only the Worksheet "Data List" is present befroe running it (i.e. delete Sheets 2 and 3 if present).
Is this doing pretty much what you require? If you need anything more post back.

Note - This could also be handy whilst you're testing this----
If you want to get back to just having your data list sheet after having generated 100+ sheets that you don't want (happened to my whilst developing this ) then use the following code to do it quickly (though ensure Data List is worksheet 1!!)

Sub ClearWorksheets()

Dim i As Integer

Do While Worksheets.Count > 1
    Worksheets(Worksheets.Count).Delete
Loop
    
End Sub

Tris

Hi Tristan,

Thanks very much for your help, for taking the time to write the code and for the offer of more help if needed. My school project is due at the end of the week and I'm almost there with it but just been a bit stuck.

On adding the code and running it an error comes up about the final "paste" in the code being incorrect but I'm not sure why.

I didn't explain in my first post but the program starts by opening a new visual basic applciation, workbook and sheets etc. The program runs from one excel document and creates another. I don't know if this has anything to do wth the location it is trying to paste in. In other parts of the code I've had to be specific about which sheet I'm using eg oWB.worksheets(..... instead of just worksheets(......


It may be easier if I paste you my program so far

'Option Explicit
Option Base 1
Dim Heats As Integer

      Dim oXL As Excel.Application
      Dim oWB As Excel.Workbook
      Dim oSheet As Excel.Worksheet
      Dim oRng As Excel.Range
   
   Private Sub CmdEnter_Click()
      'On Error GoTo Err_Handler
      
   ' Start Excel and get Application object.
      Set oXL = CreateObject("Excel.Application")
      oXL.Visible = True
      
   ' Get a new workbook.
      Set oWB = oXL.Workbooks.Add
      Set oSheet = oWB.ActiveSheet
      
   ' Add table headers going cell by cell.
      oSheet.Cells(1, 1).Value = "Name"
      oSheet.Cells(1, 2).Value = "Heat"
      oSheet.Cells(1, 3).Value = "Position"
      oSheet.Cells(1, 4).Value = "Time"

    'Renaming Main sheet = Data list
        oSheet.Name = "Data list"
'Delete Sheets 2 and 3 (unused sheets)
oXL.Sheets(2).Delete
oXL.Sheets(2).Delete



   ' Format A1:D1 as bold, vertical alignment = center.
      With oSheet.Range("A1", "C1")
         .Font.Bold = True
         .VerticalAlignment = xlVAlignCenter
      End With

      Heats = InputBox("Enter number of heats")
      
   Dim competitors As Integer
   competitors = InputBox("Enter number of competitors")




Dim sheetnew As Integer
For sheetnew = 1 To Heats
oWB.Worksheets.Add(after:=oWB.Worksheets(oWB.Worksheets.Count)).Name = "Heat " & sheetnew
Next sheetnew



'Dim Arrays
Dim saName() As String
Dim saHeat() As Integer
Dim saPosition() As Integer
Dim saTime() As Single

Dim comps As Integer


'Redim arrays with number of competitors
ReDim saName(competitors) As String
ReDim saHeat(competitors) As Integer
ReDim saPosition(competitors) As Integer
ReDim saTime(competitors) As Single

'Loop for all passengers
For comps = 1 To competitors

    Call Enter_Name(saName(), comps)

    Call Enter_Heat(saHeat(), comps)

    'Call Enter_Position(saPosition(), comps)
    Call Enter_Time(saTime(), comps)
    
Next comps


Dim rolo As Integer


   
   ' Fill A2:A6 with an array of values (Names).
    For rolo = 2 To (competitors + 1)
            oSheet.Cells(rolo, 1).Value = saName((rolo - 1))
   Next rolo

rolo = 0

   ' Fill B2:B6 with an array of values (Heats).
    For rolo = 2 To (competitors + 1)
           oSheet.Cells(rolo, 2).Value = saHeat((rolo - 1))
  Next rolo
  
  rolo = 0
  
   ' Fill C2:C6 with an array of values (Positions).
    For rolo = 2 To (competitors + 1)
            oSheet.Cells(rolo, 3).Value = saPosition((rolo - 1))
   Next rolo
      
      
         ' Fill D2:D6 with an array of values (Times).
    For rolo = 2 To (competitors + 1)
            oSheet.Cells(rolo, 4).Value = saTime((rolo - 1))
   Next rolo
      
         ' Format D2:D6(Times).
    For rolo = 2 To (competitors + 1)
            oSheet.Cells(rolo, 4).NumberFormat = "0.00"
   Next rolo

    
Call FindAndCopyRows
    
    

End Sub

Private Sub Enter_Name(ByRef saName() As String, ByVal comps As Integer)

saName(comps) = InputBox("Enter name")

End Sub

Private Sub Enter_Heat(ByRef saHeat() As Integer, ByVal comps As Integer)

saHeat(comps) = GetValidHeat

End Sub


Private Sub Enter_Position(ByRef saPosition() As Integer, ByVal comps As Integer)

saPosition(comps) = GetValidPosition

End Sub

Private Sub Enter_Time(ByRef saTime() As Single, ByVal comps As Integer)

saTime(comps) = GetValidTime

End Sub



''Functions''

Function GetValidName() As String

GetValidName = InputBox("Enter name of competitor", "Competitor Name input")


End Function



Function GetValidHeat() As Integer

Dim Num As Integer
Dim NumberValid As Boolean

NumberValid = False

Do
    Num = InputBox("Please enter heat", "Heat")
    'Seat must be in range of 1 to Number of Heats
    If (Num >= 1) And (Num <= Heats) Then NumberValid = True
    If Not NumberValid Then MsgBox ("That heat was not in the range of 1 to " & Heats)
Loop Until NumberValid

GetValidHeat = Num

End Function

Function GetValidTime() As Single

Dim Num As Single
Dim NumberValid As Boolean

NumberValid = False

Do
    Num = InputBox("Please enter time", "Time")
    'Seat must be in range of 1 to 1000
    If (Num >= 1) And (Num <= 1000) Then NumberValid = True
    If Not NumberValid Then MsgBox ("Incorrect input, Please Re-enter")
Loop Until NumberValid

GetValidTime = Num

End Function


Function GetValidPosition() As Integer

Dim Num As Integer
Dim NumberValid As Boolean

NumberValid = False

Do
    Num = InputBox("Please enter position", "Position")
    'Seat must be in range of 1 to 8
    If (Num >= 1) And (Num <= 8) Then NumberValid = True
    If Not NumberValid Then MsgBox ("Incorrect input, Please Re-enter")
Loop Until NumberValid

GetValidPosition = Num

End Function

Private Sub cmdQuit_Click()
End
End Sub


Sub FindAndCopyRows()

Dim DataListLastRow As Integer
Dim Number As Integer
Dim DataList As Worksheet
Dim i As Integer
Dim j As Integer

Set DataList = Worksheets("DataList")
DataListLastRow = DataList.Cells(65536, 2).End(xlUp).Row


For i = 1 To DataListLastRow
    Number = DataList.Cells(i, 2)
    
    For j = 2 To Worksheets.Count
        If Worksheets(j).Name = "Heat_" & Number Then GoTo InsertHeat
    Next j
        
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "Heat_" & Number

InsertHeat:
    
    DataList.Select
    
    With Worksheets("Heat_" & Number)
        DataList.Rows(i).Copy
        Paste (.Cells(65536, 1).End(xlUp).Offset(1, 0))
    End With
    
Next i

End Sub

Any ideas?

I wouldn't usually ask for so much help with this, its just I've got a really tight deadline and still have the report to write as well with teachers puting pressure on me.

Thanks again

cleaco