Macro that looks at a list of dates and returns the first ten rows of data for those dates?

[Hawk11ns]

I am looking for a macro that will look at a data set (contained in columns A through I with the 'Date' in Column B) and copy/paste the first ten lines associated with each date into a new data set until all dates are cycled through. Suggestions?

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, srcWS As Worksheet, desWS As Worksheet, item As Variant, fVisRow As Long, lastRow As Long
    Set srcWS = ThisWorkbook.Sheets("[COLOR="#FF0000"]Sheet1[/COLOR]")
    Set desWS = ThisWorkbook.Sheets("[COLOR="#FF0000"]Sheet2[/COLOR]")
    lastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    With srcWS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B2:B" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:I" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For Each Rng In srcWS.Range("B2:B" & lastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each item In RngList
        With srcWS.Cells(1).CurrentRegion
            .AutoFilter 2, item
            fVisRow = .Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
            srcWS.Rows(fVisRow).Resize(10).EntireRow.Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With
    Next item
    srcWS.Range("B1").AutoFilter
End Sub

Change the sheet names (in red) to suit your needs.

 

[Hawk11ns]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, srcWS As Worksheet, desWS As Worksheet, item As Variant, fVisRow As Long, lastRow As Long
    Set srcWS = ThisWorkbook.Sheets("[COLOR=#FF0000]Sheet1[/COLOR]")
    Set desWS = ThisWorkbook.Sheets("[COLOR=#FF0000]Sheet2[/COLOR]")
    lastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    With srcWS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B2:B" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:I" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For Each Rng In srcWS.Range("B2:B" & lastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each item In RngList
        With srcWS.Cells(1).CurrentRegion
            .AutoFilter 2, item
            fVisRow = .Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
            srcWS.Rows(fVisRow).Resize(10).EntireRow.Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With
    Next item
    srcWS.Range("B1").AutoFilter
End Sub

Change the sheet names (in red) to suit your needs.

That did exactly what I sought to do. You are amazing - thanks!

 

[mumps]

You are very welcome.