Copy multiple rows based on data to another workbook.

D

dilshod_k

Board Regular
Joined
Feb 13, 2018
Messages
79
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
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
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
 
Upvote 0
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: 8
  • Date2.PNG
    Date2.PNG
    72.2 KB · Views: 8
Upvote 0
Olukunle said:
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.
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
Olukunle said:
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
Click to expand...

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")
 
Upvote 0
Olukunle said:
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
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
dilshod_k said:
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
Click to expand...
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
VBA code to autofill based on a date?
Replies
3
Views
158
Joe4
Joe4
L
  • Solved
Macro to open multiple workbooks and copy a range of data based on todays date. Then paste the data in master workbook in one sheet under each other.
Replies
8
Views
613
Luke1690
L
E
  • Solved
Is there a VBA that searches all sheets in any workbook, for today date, and copy the entire row
Replies
5
Views
200
pitchoute
P
A
  • Question Question
How restrict copy data from form to sheet based on five days within current month
Replies
3
Views
78
Ali M
A
H
  • Solved
Automatic copy new rows in sheet. Shooter contest.
Replies
8
Views
236
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,223,896
Messages
6,175,263
Members
452,627
Latest member
KitkatToby

Share this page

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
Back
Top