Excel Macro: Copy data into new worksheet and sort base on date and random number

Question

For the following excel data:

1   Name        Date        Color_picked    
2   John      8/1/2015        Red    
3   Jason     8/13/2015       Blue  
4   Kevin     8/12/2015       Yellow    
5   Derek     8/13/2015       Blue   
6   Cherry    8/1/2015       Red

I want to do the follow:

1) Generate a random number for each of row (Not including the title row)

2) Copy all the records into a new tab/worksheet base on the color(Red, Blue and Yellow tabs)

3) Within each new tabs (Red, Blue and Yellow tabs), first sort the record by the date, if deplicated date, then sort by the random number.

This is what I have so far:

Sub myFoo()
    Application.CutCopyMode = False

    On Error GoTo Err_Execute

    Sheet1.Range("B1:F3").Copy
    Red.Range("A1").Rows("1:1").Insert Shift:=xlDown

Err_Execute:
    If Err.Number = 0 Then MsgBox "Transformation Done!" Else _
    MsgBox Err.Description

End Sub

Should I be creating the copy first or sort first?

R3uK R3uK · Accepted Answer · 2015-11-20T09:51:12

This should do the trick :

Sub test_Ryan_Fung()
Dim WsSrc As Worksheet, _
    WsRed As Worksheet, _
    WsBlue As Worksheet, _
    WsYellow As Worksheet, _
    Ws As Worksheet, _
    DateFilterRange As String, _
    RandomRange As String, _
    TotalRange As String, _
    LastRow As Long, _
    WriteRow As Long, _
    ShArr(), _
    Arr()

Set WsSrc = Sheet1
Set WsRed = Sheets("Red")
Set WsBlue = Sheets("Blue")
Set WsYellow = Sheets("Yellow")

ReDim ShArr(1 To 3)
Set ShArr(1) = WsRed: Set ShArr(2) = WsBlue: Set ShArr(3) = WsYellow

Application.CutCopyMode = False

On Error GoTo Err_Execute
With WsSrc
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    For i = 2 To LastRow
        .Cells(i, 5) = Application.WorksheetFunction.RandBetween(1, 10000)
    Next i
    Arr = .Range("A2:E" & LastRow).Value
End With

For i = LBound(Arr, 1) To UBound(Arr, 1)
    Select Case LCase(Arr(i, 4))
        Case Is = "red"
            With WsRed
                WriteRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                For j = LBound(Arr, 2) To UBound(Arr, 2)
                    .Cells(WriteRow, j) = Arr(i, j)
                Next j
            End With
        Case Is = "blue"
            With WsBlue
                WriteRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                For j = LBound(Arr, 2) To UBound(Arr, 2)
                    .Cells(WriteRow, j) = Arr(i, j)
                Next j
            End With
        Case Is = "yellow"
            With WsYellow
                WriteRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                For j = LBound(Arr, 2) To UBound(Arr, 2)
                    .Cells(WriteRow, j) = Arr(i, j)
                Next j
            End With
        Case Else
            MsgBox "Color not recognised : " & Arr(i, 4), vbCritical + vbOKOnly
    End Select
Next i

For i = LBound(ShArr, 1) To UBound(ShArr, 1)
    Set Ws = ShArr(i)
    With Ws
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        DateFilterRange = "C2:C" & LastRow
        RandomRange = "E2:E" & LastRow
        TotalRange = "A1:E" & LastRow

        With .Sort
            With .SortFields
                .Clear
                .Add Key:=Range(DateFilterRange), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                .Add Key:=Range(RandomRange), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            .SetRange Range(TotalRange)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
Next i

Err_Execute:
    If Err.Number = 0 Then
        MsgBox "Transformation Done!"
    Else
        MsgBox Err.Description
    End If

End Sub

Excel Macro: Copy data into new worksheet and sort base on date and random number

1 Answers