Question

与Excel VBA相关-我有一个很大的数据集，想按Ratings进行划分。对于小型数据集，代码可以完美运行，但对于大型数据集（11,000行和20列），它会循环并得到“重新启动Excel程序”或438错误。需要一些帮助来优化/更正代码。使用Excel 2013

我尝试了剪切/粘贴而不是复制/粘贴-它不起作用

Private Sub SplitData_Click()
    a = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To a
        If Sheets("Sheet1").Cells(i, 2).Value = "AAA" Then
            Sheets("Sheet1").Rows(i).Cut
            Sheets("Sheet2").Activate
            b = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
            Sheets("Sheet2").Cells(b + 1, 1).Select
            ActiveSheet.Paste
        End If
        If Sheets("Sheet1").Cells(i, 2).Value = "BBB" Then
            Sheets("Sheet1").Rows(i).Cut
            Sheets("Sheet3").Activate
            c = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
            Sheets("Sheet3").Cells(c + 1, 1).Select
            ActiveSheet.Paste
        End If
        If Sheets("Sheet1").Cells(i, 2).Value = "CCC" Then
            Sheets("Sheet1").Rows(i).Cut
            Sheets("Sheet4").Activate
            d = Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row
            Sheets("Sheet4").Cells(d + 1, 1).Select
            ActiveSheet.Paste
        End If
        Sheets("Sheet1").Activate
    Next
    Application.CutCopyMode = False
End Sub

我想基于AAA，BBB或CCC值将大数据集划分为不同的组（表）。我有10个这样的值标记。

Answer 1

另一种方法：

Private Sub SplitData_Click()

    Dim a As Long, i As Long, sht As Worksheet, sDest As String

    Set sht = Sheets("Sheet1")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    a = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row

    For i = a To 2 Step -1 'work from bottom up
        sDest = ""
        'need to cut this row?
        Select Case sht.Cells(i, 2).Value
            Case "AAA": sDest = "Sheet2"
            Case "BBB": sDest = "Sheet3"
            Case "CCC": sDest = "Sheet4"
        End Select
        'cut row to relevant sheet
        If Len(sDest) > 0 Then
            sht.Rows(i).Cut Sheets(sDest).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next i

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic

End Sub

注意：使用xlUp定位“剪切为”单元格依赖于目标表中的每行，且该行在ColA中具有值-如果任何行为空，则行可能会被覆盖下一个粘贴的行。

Answer 2

尝试一下。这应该更快，因为它不涉及 ANY 循环。

逻辑

使用自动过滤器一次即可复制行
复制后清除行
使用自动过滤器一次删除空白行

代码

Dim wsInput As Worksheet

Sub SplitData_Click()
    Dim wsOutputA As Worksheet
    Dim wsOutputB As Worksheet
    Dim wsOutputC As Worksheet

    Set wsInput = ThisWorkbook.Sheets("Sheet1")
    Set wsOutputA = ThisWorkbook.Sheets("Sheet2")
    Set wsOutputB = ThisWorkbook.Sheets("Sheet3")
    Set wsOutputC = ThisWorkbook.Sheets("Sheet4")

    Dim lrow As Long
    Dim rng As Range

    With wsInput
        .AutoFilterMode = False

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

        Set rng = .Range("A1:A" & lrow)

        '~~> Filter on AAA
        HandleIt "AAA", rng, wsOutputA

        '~~> Filter on BBB
        HandleIt "BBB", rng, wsOutputB

        '~~> Filter on CCC
        HandleIt "CCC", rng, wsOutputC

        '~~> Filter on blanks
        With rng
            .AutoFilter Field:=1, Criteria1:="="
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        .AutoFilterMode = False
    End With
End Sub

Private Sub HandleIt(AFCrit As String, r As Range, wks As Worksheet)
    Dim OutputRow As Long
    Dim filteredRange As Range

    With r
        .AutoFilter Field:=1, Criteria1:=AFCrit
        Set filteredRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With

    If Not filteredRange Is Nothing Then
        With wks
            OutputRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            filteredRange.Copy .Rows(OutputRow)
            filteredRange.ClearContents
        End With
    End If

    wsInput.ShowAllData
End Sub

实际操作

注意：上面的代码在21k行x 31列数据上花费了4秒钟

Answer 3

请参阅How to avoid using Select in Excel VBA。

Option Explicit

Private Sub SplitData_Click()
    Dim i As Long

    With Worksheets("Sheet1")
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            Select Case .Cells(i, 2).Value
            Case "AAA"
                MoveToEndOf .Rows(i), Worksheets("Sheet2")
            Case "BBB"
                MoveToEndOf .Rows(i), Worksheets("Sheet3")
            Case "CCC"
                MoveToEndOf .Rows(i), Worksheets("Sheet4")
            End Select
        Next
    End With
End Sub

Private Sub MoveToEndOf(ByVal what As Range, ByVal where As Worksheet)
    what.Cut where.Cells(where.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub

Answer 4

这里是不使用复制/粘贴的选项

Private Sub SplitData_Click()
    Dim a As Long
    Dim b As Long
    Dim c As Long
    Dim d As Long
    Dim i As Long

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet

    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    Set ws4 = ThisWorkbook.Sheets("Sheet4")

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    a = ws1.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To a

        If ws1.Cells(i, 2).Value = "AAA" Then
            b = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            ws2.Rows(b).Value = ws1.Rows(i).Value

        End If
        If ws1.Cells(i, 2).Value = "BBB" Then
            c = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row + 1
            ws2.Rows(c).Value = ws1.Rows(i).Value
        End If
        If ws1.Cells(i, 2).Value = "CCC" Then
            d = Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row + 1
            ws2.Rows(d).Value = ws1.Rows(i).Value
        End If

    Next i
    With Application
             .ScreenUpdating = True
             .Calculation = xlCalculationAutomatic
    End With
End Sub

错误438“对象不支持此属性或方法”

4 个答案: