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）在每一個新的選項卡（紅，藍一個d黃色選項卡），首先按照日期對記錄進行排序，如果顯示日期，則按隨機數進行排序。

這是我到目前爲止有：

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