• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

break-data-example VBA Macro- by ranges

Khaledalaydi

Khaledalaydi

New Member
Hello,

Thanks @chirayu for the tip of creating a new thread :)

I looked at the example of breaking data by chandoo. The data is divided into new excelbooks according to name of employees. I am trying to copy the same macro to my case where I am trying to divide an excel into several sheets but by a range of dates instead. I am attaching an example of how my results look like. I know that the date is not in the right format but that shouldnt be a problem because the macro will look for range of "text".

So as a summary, a user will write two dates and the macro will create a new sheet copying everything in between thsese two dates with the colums to the right as well.
 

Attachments

  • m7709 6m.xlsx
    149.5 KB · Views: 5
try this

Code: 
Sub DateSplit()

'Define Variables
'----------------
Dim StDate As Variant
Dim EndDate As Variant
Dim YR As Integer
Dim MTH As Integer
Dim DY As Integer
Dim StRow As Variant
Dim LstRow As Variant
Dim Rng As Range
Dim CurrWB As String
Dim NewWB As String

CurrWB = ActiveWorkbook.Name

'Set Start Date
'--------------
StDate = Application.InputBox("Date Format YYYY/MM/DD e.g. 2018/01/30", "Start Date")

If StDate = False Then
    MsgBox "Start Date Cancelled" & vbNewLine & "Macro will now exit", vbCritical, ""
    Exit Sub
ElseIf StDate = "" Then
    MsgBox "Start Date is empty" & vbNewLine & "Macro will now exit", vbCritical, ""
    Exit Sub
ElseIf Not StDate Like "####/##/##" Then
    MsgBox "Start Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
    Exit Sub
Else
   
    YR = Split(StDate, "/")(0)
    MTH = Split(StDate, "/")(1)
    DY = Split(StDate, "/")(2)
   
    If MTH >= 12 Then
        MsgBox "Start Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
        Exit Sub
    End If
       
        StDate = DateSerial(YR, MTH, DY)
End If
   
   
    'Define End Date
    '---------------
    EndDate = Application.InputBox("Date Format YYYY/MM/DD e.g. 2018/01/30", "End Date")
   
    If EndDate = False Then
        MsgBox "End Date Cancelled" & vbNewLine & "Macro will now exit", vbCritical, ""
        Exit Sub
    ElseIf EndDate = "" Then
        MsgBox "End Date is empty" & vbNewLine & "Macro will now exit", vbCritical, ""
        Exit Sub
    ElseIf Not EndDate Like "####/##/##" Then
        MsgBox "End Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
        Exit Sub
    Else
       
        YR = Split(EndDate, "/")(0)
        MTH = Split(EndDate, "/")(1)
        DY = Split(EndDate, "/")(2)
       
        If MTH >= 12 Then
            MsgBox "End Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
            Exit Sub
        End If
           
            EndDate = DateSerial(YR, MTH, DY)
    End If
   
    'Find Last Row and add Date conversion formula
    '---------------------------------------------
    LstRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("E2:E" & LstRow).Formula = "=IFERROR(DATE(LEFT(A2,4),MID(A2,6,2),MID(A2,9,2)),E1)"
    Range("E2:E" & LstRow).Copy
    Range("E2").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
   
    'Set Copy Range
    '--------------
    Range("G2") = StDate
    Range("G3") = EndDate
    Range("H2").Formula = "=MIN(MATCH(G2,E:E,0))"
    Range("H3").Formula = "=MAX(MATCH(G3,E:E,1))"
    StRow = Range("H2")
    LstRow = Range("H3")
    Range("E:H").Delete
    Set Rng = Range("A" & StRow & ":C" & LstRow)
    Range("A1:C1").Copy
   
    'Paste to different file
    '------------------------
    Workbooks.Add
    NewWB = ActiveWorkbook.Name
    Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Windows(CurrWB).Activate
    Rng.Copy
    Windows(NewWB).Activate
    Range("A2").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
       
    'Finish
    '------
    MsgBox "Macro completed", vbInformation, ""
   
End Sub
 
Thanks so much mate, you are awesome. Just one more thing is it possible to edit it so that hte user can enter even the time in hh:mm as well?
 
updated. will take just date or date and time

Code: 
Sub DateTimeSplit()

'Define Variables
'----------------
Dim StDate As Variant 'Start Date - for copying range and date checks
Dim StTime As Variant 'Start Time - for copying range and time checks
Dim EndDate As Variant 'End Date - for copying range and date checks
Dim EndTime As Variant 'End Time - for copying range and time checks
Dim MTH As Integer 'Month - for date checks
Dim StRow As Variant 'Start Row - for copying range
Dim LstRow As Variant 'End Row - for copying range
Dim Rng As Range 'for copying range
Dim CurrWB As String 'File to copy from
Dim NewWB As String 'File to paste to
Dim Chk As Integer 'check if time needed by user

CurrWB = ActiveWorkbook.Name

If MsgBox("Do you also want to check time?", vbYesNo, "") = vbNo Then Chk = 1 Else Chk = 2

    'Set Start Date
    '--------------
    StDate = Application.InputBox("Date Format YYYY/MM/DD e.g. 2018/01/30", "Start Date")
   
    If StDate = False Then
        MsgBox "Start Date Cancelled" & vbNewLine & "Macro will now exit", vbCritical, ""
        Exit Sub
    ElseIf StDate = "" Then
        MsgBox "Start Date is empty" & vbNewLine & "Macro will now exit", vbCritical, ""
        Exit Sub
    ElseIf Not StDate Like "####/##/##" Then
        MsgBox "Start Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
        Exit Sub
    Else
     
        MTH = Split(StDate, "/")(1)
       
        If MTH >= 12 Then
            MsgBox "Start Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
            Exit Sub
        End If
         
        StDate = CDate(StDate)
    End If
       
       
        'Set Start Time
        '--------------
        If Chk = 2 Then
            StTime = Application.InputBox("Date Format HH:MM 24 hour format e.g. 17:30", "Start Time")
           
            If StTime = False Then
                MsgBox "Start Time Cancelled" & vbNewLine & "Macro will now exit", vbCritical, ""
                Exit Sub
            ElseIf StTime = "" Then
                MsgBox "Start Time is empty" & vbNewLine & "Macro will now exit", vbCritical, ""
                Exit Sub
            ElseIf Not StTime Like "##:##" Then
                MsgBox "Start Time is in incorrect format" & vbNewLine & "Must be HH:MM 24 hour format" & vbNewLine & "Macro will now exit", vbCritical, ""
                Exit Sub
            Else
                StTime = CDate(StTime)
            End If
        End If
           
            'Set End Date
            '-------------
            EndDate = Application.InputBox("Date Format YYYY/MM/DD e.g. 2018/01/30", "End Date")
           
            If EndDate = False Then
                MsgBox "End Date Cancelled" & vbNewLine & "Macro will now exit", vbCritical, ""
                Exit Sub
            ElseIf EndDate = "" Then
                MsgBox "End Date is empty" & vbNewLine & "Macro will now exit", vbCritical, ""
                Exit Sub
            ElseIf Not EndDate Like "####/##/##" Then
                MsgBox "End Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
                Exit Sub
            Else
               
                MTH = Split(EndDate, "/")(1)
               
                If MTH >= 12 Then
                    MsgBox "End Date is in incorrect format" & vbNewLine & "Must be YYYY/MM/DD" & vbNewLine & "Macro will now exit", vbCritical, ""
                    Exit Sub
                End If
                   
                    EndDate = CDate(EndDate)
            End If
           
                'Set End Time
                '------------
                If Chk = 2 Then
                    EndTime = Application.InputBox("Date Format HH:MM 24 hour format e.g. 17:30", "End Time")
                   
                    If EndTime = False Then
                        MsgBox "End Time Cancelled" & vbNewLine & "Macro will now exit", vbCritical, ""
                        Exit Sub
                    ElseIf EndTime = "" Then
                        MsgBox "End Time is empty" & vbNewLine & "Macro will now exit", vbCritical, ""
                        Exit Sub
                    ElseIf Not EndTime Like "##:##" Then
                        MsgBox "End Time is in incorrect format" & vbNewLine & "Must be HH:MM 24 hour format" & vbNewLine & "Macro will now exit", vbCritical, ""
                        Exit Sub
                    Else
                        EndTime = CDate(EndTime)
                    End If
                End If
                   
                    'Combine Date & Time
                    '-------------------
                    If Chk = 2 Then StDate = StDate + StTime
                    If Chk = 2 Then EndDate = EndDate + EndTime
                   
                    'Add Date + Time conversion formulae
                    '-----------------------------------
                    LstRow = Cells(Rows.Count, "A").End(xlUp).Row
                    Range("E2:E" & LstRow).Formula = "=IFERROR(DATE(LEFT(A2,4),MID(A2,6,2),MID(A2,9,2)),E1)" 'Split Date from column A
                    Range("F2:F" & LstRow).Formula = "=IFERROR(MID(A2,12,5)*1,F1)" 'Split Time from column A
                    Range("G2:G" & LstRow).Formula = "=E2+F2" 'Date + Time
                    Range("E2:G" & LstRow).Copy
                    Range("E2").PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                   
                    'Paste Criteria
                    '---------------
                    Range("J2") = StDate
                    Range("J3") = EndDate
                   
                    'Paste Range check formula
                    '-------------------------
                    If Chk = 2 Then
                        Range("H2:H" & LstRow).Formula = "=IF(AND(G2>=$J$2,G2<=$J$3),""A"",""B"")"
                    Else
                        Range("H2:H" & LstRow).Formula = "=IF(AND(E2>=$J$2,E2<=$J$3),""A"",""B"")"
                    End If
                       
                        Range("H2:H" & LstRow).Copy
                        Range("H2").PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                        Range("K2").Formula = "=MATCH(""A"",H:H,0)"
                        Range("K3").Formula = "=MATCH(""A"",H:H,1)"
                       
                        'Set Range
                        '---------
                        StRow = Range("K2")
                        LstRow = Range("K3")
                        Range("E:K").Delete
                        Set Rng = Range("A" & StRow & ":C" & LstRow)
                       
                        'Paste to different file
                        '------------------------
                        Range("A1:C1").Copy
                        Workbooks.Add
                        NewWB = ActiveWorkbook.Name
                        Range("A1").PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                        Windows(CurrWB).Activate
                        Rng.Copy
                        Windows(NewWB).Activate
                        Range("A2").PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                           
                        'Finish
                        '------
                        MsgBox "Macro completed", vbInformation, ""
       
End Sub
 
Man, you are the king!
It works so perfectly, I am working a bit on it to make it more applicable with buttons and so but since the code is pasting and deleting columns it is quite hard, but I will give it a try!
 
well. you can always change the .Delete to .ClearContents
so it clears the columns of data rather than delete the column
 
You must log in or register to reply here.
Back
Top