Copy multiple rows based on data to another workbook.

dilshod_k

Board Regular
Joined
Feb 13, 2018
Messages
76
Hello everyone,

I’ve workbook with data (range A to M) sorted in chronological descending order, around 100k rows.
The aim is to create code that copies all rows with the same date (dates in column B) to workbook Results.xlsm, adds sheet with name equal to that date and then does the same thing with data corresponding to the previous date. For example copy of all rows with date 12/31/2020 to a new sheet, name that sheet 12.31.2020, and go next to 12/30/2020 e.t.c. I know function how to find single row with a given date, but I could not figure out how to copy multiple rows based on certain criteria to another workbook. I would be grateful for any help. Thanks in advance.
Dilshod
 

Some videos you may like

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

Olukunle

New Member
Joined
Oct 31, 2012
Messages
16
VBA Code:
Sub CopySameDate()
Application.ScreenUpdating = False
With Sheet1 ' Replace this with your data sheet code name or worksheet name
    .Range("XFD1") = .Range("A1").Value
    a_su = DistinctVals(.Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)) ' Assumes your date value is in Column A
    For J = 1 To UBound(a_su)
        .Range("XFD2") = a_su(J, 1)
        Sheets.Add(, Sheets(Sheets.Count)).Name = Format(a_su(J, 1), "mm.dd.yy")
        .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("XFD1:XFD2"), _
        CopyToRange:=ActiveSheet.Range(Cells(1, 1), Cells(1, .Range("A1").CurrentRegion.Columns.Count)), Unique:=False
    Next J
    .Range("XFD1:XFD2").Clear
End With
End Sub

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next i
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function
 

dilshod_k

Board Regular
Joined
Feb 13, 2018
Messages
76
Hi Olukunle,
Thanks very much for your help, but your code copies only one row with given date to a new sheet, then it tries to add another sheet. The rest of the rows with given date remain uncopied. If it would be possible I would upload sample workbook but it is not possible in this forum.
Dilshod
 

Attachments

  • Date1.PNG
    Date1.PNG
    131.5 KB · Views: 2
  • Date2.PNG
    Date2.PNG
    72.2 KB · Views: 2

dilshod_k

Board Regular
Joined
Feb 13, 2018
Messages
76

ADVERTISEMENT

Hello Dilshod,
I am clear as to what your challenge with the code might be. Because I tested it and it worked fine for me.
Hello Olukunle,

When I try to use it without modifications to the code it works perfectly smooth, so it sorts all rows by value in column A (column A contains stock symbols) and creates multiple new sheets with names equal to stock symbols. Each new sheet contains data with various dates but all related to a single stock symbol. What I needed is to sort them by date and create sheets with names equal to date, in that case each new sheet would have name equal to given date and contain data with various stock symbols but the same date. In my table dates are in column B. When I tried to modify code by replacing A by B, it adds first new sheet with name equal to date but instead copying all rows with the same date it copies a single row corresponding to that date and then tries to add another sheet with the same name and obviously gives error message. I was not be able to modify code to make it work (I'm not a programmer) and would be grateful if you would do it for me.
Thank you.
Dilshod
 

Olukunle

New Member
Joined
Oct 31, 2012
Messages
16
Try this
VBA Code:
Sub CopySameDate()
Application.ScreenUpdating = False
With Sheet1 ' Replace this with your data sheet code name or worksheet name
    .Range("XFD1") = .Range("A1").Value
    a_su = DistinctVals(.Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row)) ' This is only line I modified
    For J = 1 To UBound(a_su)
        .Range("XFD2") = a_su(J, 1)
        Sheets.Add(, Sheets(Sheets.Count)).Name = Format(a_su(J, 1), "mm.dd.yy")
        .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("XFD1:XFD2"), _
        CopyToRange:=ActiveSheet.Range(Cells(1, 1), Cells(1, .Range("A1").CurrentRegion.Columns.Count)), Unique:=False
    Next J
    .Range("XFD1:XFD2").Clear
End With
End Sub

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next i
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function
 

dilshod_k

Board Regular
Joined
Feb 13, 2018
Messages
76

ADVERTISEMENT

Try this
VBA Code:
Sub CopySameDate()
Application.ScreenUpdating = False
With Sheet1 ' Replace this with your data sheet code name or worksheet name
    .Range("XFD1") = .Range("A1").Value
    a_su = DistinctVals(.Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row)) ' This is only line I modified
    For J = 1 To UBound(a_su)
        .Range("XFD2") = a_su(J, 1)
        Sheets.Add(, Sheets(Sheets.Count)).Name = Format(a_su(J, 1), "mm.dd.yy")
        .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("XFD1:XFD2"), _
        CopyToRange:=ActiveSheet.Range(Cells(1, 1), Cells(1, .Range("A1").CurrentRegion.Columns.Count)), Unique:=False
    Next J
    .Range("XFD1:XFD2").Clear
End With
End Sub

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next i
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function

This modification adds first new sheet with name equal to date but the sheet is empty contains only title bar, and then tries to add another sheet with the same name and gives error message at line:

Rich (BB code):
Sheets.Add(, Sheets(Sheets.Count)).Name = Format(a_su(J, 1), "mm.dd.yy")
 

Olukunle

New Member
Joined
Oct 31, 2012
Messages
16
Try this
VBA Code:
Sub CopySameDate()
Application.ScreenUpdating = False
With Sheet1 ' Replace this with your data sheet code name or worksheet name
    .Range("XFD1") = .Range("A1").Value
    a_su = DistinctVals(.Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row)) ' This is only line I modified
    For J = 1 To UBound(a_su)
        .Range("XFD2") = a_su(J, 1)
        Sheets.Add(, Sheets(Sheets.Count)).Name = Format(a_su(J, 1), "mm.dd.yy")
        .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("XFD1:XFD2"), _
        CopyToRange:=ActiveSheet.Range(Cells(1, 1), Cells(1, .Range("A1").CurrentRegion.Columns.Count)), Unique:=False
    Next J
    .Range("XFD1:XFD2").Clear
End With
End Sub

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next i
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function
Hello Dilshod,
Please use this:

VBA Code:
Sub CopySameDate()
Application.ScreenUpdating = False
With Sheet1 ' Replace this with your data sheet code name or worksheet name
    .Range("XFD1") = .Range("B1").Value
    a_su = DistinctVals(.Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row)) ' This is only line I modified
    For J = 1 To UBound(a_su)
        .Range("XFD2") = a_su(J, 1)
        Sheets.Add(, Sheets(Sheets.Count)).Name = Format(a_su(J, 1), "mm.dd.yy")
        .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("XFD1:XFD2"), _
        CopyToRange:=ActiveSheet.Range(Cells(1, 1), Cells(1, .Range("A1").CurrentRegion.Columns.Count)), Unique:=False
    Next J
    .Range("XFD1:XFD2").Clear
End With
End Sub

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next i
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function
 

dilshod_k

Board Regular
Joined
Feb 13, 2018
Messages
76
Hello Olukunle,

it adds first new sheet with name equal to date but instead copying all rows with the same date it copies a single row corresponding to that date and then tries to add another sheet with the same name and obviously gives error message at the same line
 

Olukunle

New Member
Joined
Oct 31, 2012
Messages
16
Hello Olukunle,

it adds first new sheet with name equal to date but instead copying all rows with the same date it copies a single row corresponding to that date and then tries to add another sheet with the same name and obviously gives error message at the same line
Try this again, I have modified it to work with your data. I tested it and it was fine.
VBA Code:
Sub CopySameDate()
Application.ScreenUpdating = False
With Sheet1 ' Replace this with your data sheet code name or worksheet name
    .Range("XFD1") = .Range("B1").Value
    a_su = DistinctVals(.Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row)) ' This is only line I modified
    For J = 1 To UBound(a_su)
        .Range("XFD2") = a_su(J, 1)
        Sheets.Add(, Sheets(Sheets.Count)).Name = Format(a_su(J, 1), "mm.dd.yy")
        .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("XFD1:XFD2"), _
        CopyToRange:=ActiveSheet.Range(Cells(1, 1), Cells(1, .Range("A1").CurrentRegion.Columns.Count)), Unique:=False
    Next J
    .Range("XFD1:XFD2").Clear
End With
End Sub

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next i
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function
 

Watch MrExcel Video

Forum statistics

Threads
1,122,168
Messages
5,594,632
Members
413,919
Latest member
ZaxAlchemist

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