Excelmacros：将数据复制到新工作表中，并根据date和随机数进行sorting

对于以下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）将所有logging复制到基于颜色（红色，蓝色和黄色选项卡）的新选项卡/工作表中

3）在每个新选项卡（红色，蓝色和黄色选项卡）内，首先按date对logging进行sorting，如果显示date，则按随机数进行sorting。

这是我迄今为止：

 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 

我应该先创build副本还是先sorting？

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