Question

我正在编写一个子程序来动态地将2列从一个工作表复制到另一个工作表。这些列长度可能会从一个报告更改为另一个报告。

以下是代码：

Sub getAnalystsCount()

    Dim rng As Range
    Dim dict As Object
    Set dict = CreateObject("scripting.dictionary")
    Dim varray As Variant, element As Variant

    Set ws = ThisWorkbook.Worksheets("ReportData")

    With ws
        Worksheets("ReportData").Activate

    Columns("E:E").Select
    ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Add Key:= _
        Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    lastrow = .Range("A" & .Rows.Count).End(xlUp).Row


    '~~> Set First row
    firstrow = 2

    '~~> Set your range
    Set rng = .Range("E" & firstrow & ":E" & lastrow)

    varray = rng.Value

    'Generate unique list and count
    For Each element In varray
        If dict.Exists(element) Then
            dict.Item(element) = dict.Item(element) + 1
        Else
            dict.Add element, 1
        End If
    Next
End With

Set ws = ThisWorkbook.Worksheets("Analysts")

With ws
    Worksheets("Analysts").Activate

    'Paste report somewhere
    ws.Range("A3").Resize(dict.Count, 1).Value = _
        WorksheetFunction.Transpose(dict.Keys)
    ws.Range("B3").Resize(dict.Count, 1).Value = _
        WorksheetFunction.Transpose(dict.Items)
     ......

错误在这一行：

    ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Clear

Answer 1

替换以下代码

Columns("E:E").Select
    ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort.SortFields.Add Key:= _
        Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("ReportData").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

使用以下代码

Columns("E:E").Select
lastrow1 = .Range("E" & .Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Add Key:=Range("E1") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ReportData").Sort
    .SetRange Range("E2:E" & lastrow1)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Answer 2

startCell = Range("A1").Address
endCell = Range("E100000").End(xlUp).Address
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ReportData").Sort.SortFields.Add Key:=Range("E1"), SortOn:=xlSortOnValues, Order:=xlDescending,  DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("ReportData").Sort
    .SetRange Range(startCell,endCell)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

显然这很粗糙，你需要自己创建它，但是它允许你对E列进行排序，这是你初始代码看起来像是试图做的那样。

Answer 3

Range.Sort method可用于快速单列排序，并丢弃记录工作表排序操作时产生的大部分详细代码。没有活跃的AutoFilter，这是更好的方法。

Sub getAnalystsCount()
    Dim el As Long, ws As Worksheet
    Dim dict As Object
    Dim varray As Variant

    Set dict = CreateObject("scripting.dictionary")
    'don't know what is in column E but this might be helpful
    'dict.comparemode = vbTextCompare  'non-case-sensitive

    Set ws = ThisWorkbook.Worksheets("ReportData")
    With ws
        'this is not necessary inside a With ... End With block
        'Worksheets("ReportData").Activate
        With .Range("A1").CurrentRegion
            'this quick code line is all you need
            .Cells.Sort Key1:=.Columns(5), Order1:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlYes
            'resize to # of rows -1 × 1 column and shift 1 row down and over to column E
            With .Resize(.Rows.Count - 1, 1).Offset(1, 4)
                'store the raw values
                varray = .Value2
            End With
        End With
    End With 'done with the ReportData worksheet

    'Generate unique list and count
    'I prefer to work with LBound and UBound
    For el = LBound(varray, 1) To UBound(varray, 1)
        If dict.Exists(varray(el, 1)) Then
            dict.Item(varray(el, 1)) = dict.Item(varray(el, 1)) + 1
        Else
            dict.Add Key:=varray(el, 1), Item:=1
        End If
    Next el

    Set ws = ThisWorkbook.Worksheets("Analysts")
    With ws
        'this is not necessary inside a With ... End With block
        'Worksheets("Analysts").Activate

        'might want to clear the destination cell contents first if there is something there
        if application.counta(.Range("A3:B3") = 2 then _
            .Range("A3:B" & .Cells(Rows.Count, "B").End(xlUp).Row).ClearContents

        'Paste report somewhere
        .Range("A3").Resize(dict.Count, 1).Value = _
            WorksheetFunction.Transpose(dict.Keys)
        .Range("B3").Resize(dict.Count, 1).Value = _
            WorksheetFunction.Transpose(dict.Items)
    End With 'done with the Analysts worksheet

End Sub

我更喜欢使用LBound和UBound函数来确定数组的范围。

当您在With ... End With statement内时，请使用.记下父工作表并弃掉Range .Activate方法和ws变量。

排序时运行时错误91

3 个答案: