Question

亲爱的，VBA中的一个新功能，在下面我根据我的工作需要创建此vba宏，用于将Sheet1的数据行分配到基于以下内容的不同工作表（2,3,4,5）和列表工作表（6）：如果sheet1列A中的单元格值与sheet6列A匹配，则将原始数据从sheet1移至sheet2 如果sheet1列A中的单元格值与sheet6列B匹配，则将原始数据从sheet1移至sheet3 等等。但是我的代码花了很长时间（非常慢）请需要您的帮助。

    Sub distribute()

    Application.ScreenUpdating = False

    Dim Base As Worksheet 
    Dim List As Worksheet 
    Dim i As Integer 
    Dim LastRow As Long

    Set Base = Sheets(1)
    Set List = Sheets(7)

    LastRow = Base.Cells(Base.Rows.Count, "B").End(xlUp).Row

    For i = LastRow To 1 Step -1
    For b = 2 To LastRow

    If Base.Cells(i, 2).Value = List.Cells(b, 1).Value Then
    Base.Rows(i).EntireRow.Copy _
    Destination:=Sheets(2).Rows(Sheets(2).Cells(Sheets(2).Rows.Count, 1).End(xlUp).Row + 1).EntireRow
             
    Base.Rows(i).EntireRow.Delete
    Else
    If Base.Cells(i, 2).Value = List.Cells(b, 2).Value Then
   Base.Rows(i).EntireRow.Copy _
   Destination:=Sheets(3).Rows(Sheets(3).Cells(Sheets(3).Rows.Count, 1).End(xlUp).Row + 1).EntireRow

   Base.Rows(i).EntireRow.Delete
   Else
   If Base.Cells(i, 2).Value = List.Cells(b, 3).Value Then
   Base.Rows(i).EntireRow.Copy _
   Destination:=Sheets(4).Rows(Sheets(4).Cells(Sheets(4).Rows.Count, 1).End(xlUp).Row + 1).EntireRow

   Base.Rows(i).EntireRow.Delete
   Else
   If Base.Cells(i, 2).Value = List.Cells(b, 4).Value Then
   Base.Rows(i).EntireRow.Copy _
   Destination:=Sheets(5).Rows(Sheets(5).Cells(Sheets(5).Rows.Count, 1).End(xlUp).Row + 1).EntireRow

   Base.Rows(i).EntireRow.Delete
   End If
    End If
    End If
    End If

    Next b
    Next i

    Application.ScreenUpdating = True

    End Sub

Answer 1

我使用一些样本数据表来运行您的代码，对我而言，它运行得足够快。您可以添加以下ff代码以优化过程。

    Sub distribute()
    
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.EnableEvents = False

.....rest of the code 

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

如果需要，另一个提示。尝试使用CUT代替复制，然后可以删除代码：

Base.Rows(i).EntireRow.Delete

使用剪切代替复制

If Base.Cells(i, 2).Value = List.Cells(b, 2).Value Then
Base.Rows(i).EntireRow.Cut Destination:=Sheets(3).Rows(Sheets(3).Cells(Sheets(3).Rows.Count, 1).End(xlUp).Row + 1).EntireRow

VBA将原始数据从源工作表移动到基于不同列的不同工作表

1 个答案: