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

Hawk11ns

Board Regular
Joined
Jul 21, 2015
Messages
58
Office Version
  1. 365
Platform
  1. Windows
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?
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
12,312
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
Try:
Code:
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

Board Regular
Joined
Jul 21, 2015
Messages
58
Office Version
  1. 365
Platform
  1. Windows
Try:
Code:
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

Well-known Member
Joined
Apr 11, 2012
Messages
12,312
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
You are very welcome. :)
 

Forum statistics

Threads
1,181,757
Messages
5,931,863
Members
436,805
Latest member
waseem abbas

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top