VBA根据不同的列将原始数据从源表移动到不同的表

Question

亲爱的，我是 VBA 的新手，在下面我为我的工作需要创建了这个 vba 宏，将数据行从 Sheet1 分配到不同的工作表 (2,3,4,5) 和列表表 (6)，基于： 如果 sheet1 列 A 中的单元格值与 sheet6 列 A 匹配，则将 raw 从 sheet1 移动到 sheet2 如果 sheet1 列 A 中的单元格值与 sheet6 列 B 匹配，则将 raw 从 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