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

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

1 个答案: