Sorting Data on to sub worksheet by date

N

Newbienew

Active Member
Joined
Mar 17, 2017
Messages
395
Office Version
  1. 2016
Platform
  1. Windows
So I am looking to sort data on one specific sheet to other sheets by the date. I watch a video on it on youtube but it seemed to be a lot. This was the title of the video "Spreadsheets: How to Sort Data Onto Sub Sheets". I was hoping there might be a better way to do this or achieve this goal. I will have a total of 12 months and one sheet for historic data. I thank you for your help in advance[/COLOR]
 
Last edited:

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
The YouTube link did not post correctly. Unable to determine what it is you are speaking of.

Is this the video you were referencing ? https://www.youtube.com/watch?v=_nM4YdVySAc

If so ... which column are you wanting to sort on ? The video shows Col E.
 
Last edited:
Upvote 0
I did not post the link just what i search phrased i looked up.
 
Upvote 0
Yes that is the video. The breakdown of the worksheet goes from A to S. The first three columns, A-C contain information and still needs to be in those columns. The sorting column is D, which contains the date that I hope to sort into the sheets of those months. The idea is to duplicate the main sheet layout with out adding any new columns if possible
 
Upvote 0
.
Provide a sample of how the dates are entered in to the cells in Col D.
 
Upvote 0
.
Code: 
Option Explicit


Sub CreateSheets()


    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet


        Set RngBeg = Worksheets("Sheet1").Range("D2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)


        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Format(Cell.Value, "[$-409]dmmmyy;@"))


                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Format(Cell.Value, "[$-409]dmmmyy;@")
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub


Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub


Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error GoTo M
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
Dim ans As String
Dim ans2 As String


NoVisi


    For i = 2 To Lastrow
    ans = Sheets("Sheet1").Cells(i, 4).Value
    ans2 = Format(ans, "[$-409]dmmmyy;@")
        Sheets("Sheet1").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Next
    
Visi


Application.ScreenUpdating = True


Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select


Exit Sub


M:
MsgBox "No such sheet as  " & ans & " exist"
Application.ScreenUpdating = True


End Sub


Sub NoVisi()
Dim myshape As Shape
    
    For Each myshape In Sheet1.Shapes
        myshape.Visible = False
    Next myshape


End Sub


Sub Visi()
Dim myshape As Shape
    
    For Each myshape In Sheet1.Shapes
        myshape.Visible = True
    Next myshape


End Sub


Download workbook : https://www.amazon.com/clouddrive/share/RK1jcDe6A4xF62I0CFQNaIZhG7aoVtbl7ewPZYn6Dnd
 
Upvote 0
I ran the code but it gives me an error of

Run-time error' -2147024891 (80070005)

Access denied. You do not have enough privileges to to complete this operation


Then when I hit the debug button this is highlighted
myshape.Visible = True
 
Upvote 0
.
That is curious. That line of code refers to the command button located on Sheet1.
The opposite of that macro is NoVisi which makes the command button become invisible. That is done
so the button is not copied to each of the newly created sheets.

I would think if the code were going to error it would do so on the first macro where the button is made
invisible.

I changed the code to utilize a CommandButton (ActiveX) rather than a userform button. Here is the code :

Code: 
Option Explicit


Sub CreateSheets()


    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet


        Set RngBeg = Worksheets("Sheet1").Range("D2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)


        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Format(Cell.Value, "[$-409]dmmmyy;@"))


                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Format(Cell.Value, "[$-409]dmmmyy;@")
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub


Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub


Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error Resume Next
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
Dim ans As String
Dim ans2 As String


NoVisi


    For i = 2 To Lastrow
    ans = Sheets("Sheet1").Cells(i, 4).Value
    ans2 = Format(ans, "[$-409]dmmmyy;@")
        Sheets("Sheet1").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Next
    
Visi


Application.ScreenUpdating = True


Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select


Exit Sub


Application.ScreenUpdating = True


End Sub


Sub NoVisi()
Dim CommandButton1 As Object


CommandButton1.Visible = False


End Sub


Sub Visi()
Dim CommandButton1 As Object


CommandButton1.Visible = True
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/H5xVASDWgHWO3cXVyUy9znxXQmf1pJqJ6Trcpr362WT
 
Upvote 0
I didn't realize that you added a example on the bottom of the posting, I feel so silly. I see how it is suppose to work now. I posted the code on my workbook but it didn't work out without me making additional buttons. I noticed that it makes a new sheet for every date. This is along the longs of what i was looking to do, but have any date in that month. So if there is 6 dates in the same month those would all get transferred to that sheet (APR). And ever time a new entry is made on the primary sheet it will autofill on the sheet based on that month.

Moreover, how do I posted a cloud link as you did. If so i can better show you. In addition it would make it easier for me on the site to explain things better as well. Thank you ssoooo much
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Condition format highlight duplicates between sheets
Replies
3
Views
150
6StringJazzer
6StringJazzer
S
  • Solved
Show a worksheet when user click on it and hide it once user switched to another sheet
Replies
5
Views
125
DanteAmor
DanteAmor
J
  • Question Question
Newer user looking to link multiple tables that autopopulate data based on results
Replies
5
Views
84
Jaytam49
J
N
  • Question Question
ActiveX Option Button to sort Data in another sheet and update conbobox
2 3
Replies
22
Views
344
NUC_N_FUTS2
N
A
  • Question Question
Excel - looking up data with multiple criteria from table/array, date must be same or nearest before the target cell
Replies
8
Views
626
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

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