Excel 宏：将数据复制到新工作表中并根据日期和随机数进行排序

Question

对于以下excel数据：

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 

我想做以下事情：

1) 为每一行生成一个随机数（不包括标题行）

2) 根据颜色（红色、蓝色和黄色标签）将所有记录复制到新标签/工作表中

3) 在每个新的标签页（红色、蓝色和黄色标签页）中，首先按日期对记录进行排序，如果删除日期，则按随机数排序。

这是我目前所拥有的：

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

我应该先创建副本还是先排序？

Answer 1

这应该可以解决问题：

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