时间戳

首页 > 解决方案 > 如何使用 VBA 根据标准将数据集从一张表移动到另一张表

excel - 如何使用 VBA 根据标准将数据集从一张表移动到另一张表

问题描述

我正在尝试将数据从一个名为 on 的表移动Raw_Data到sheet Raw Data另一个名为Phone_Numberon的表sheet No Quality。

我的表格有16 列，我需要确认原始数据表的第 15 列是否包含No Quality或PH Phone字样。如果是这样，那么我想将数据移动到“无质量”表并将其粘贴到那里的表格中。粘贴后，我想从原始数据表中删除数据。

我尝试了几种不同的方法，但似乎无法让它们发挥作用。这是我使用的第一种方法

Sub Numbers()

    Dim dataSheet As Worksheet, newSheet As Worksheet
    Dim dataTable As ListObject, newTable As ListObject
    Dim dataCount As Long
    Dim checkOne As String, checkTwo As String
    Dim copyRange As Range
    
    Set dataSheet = Worksheets("Raw Data")
    Set newSheet = Worksheets("No Quality")
    Set dataTable = dataSheet.ListObjects("Raw_Data")
    Set newTable = newSheet.ListObjects("Phone_Number")
    checkOne = "PH Phone"
    checkTwo = "No Quality"
    dataCount = dataSheet.ListObjects("Raw_Data").ListRows.Count
    dataValue = dataSheet.ListObjects("Raw_Data").DataBodyRange(dataCount, "O").Value
    dataLocation = dataSheet.ListObjects("Raw_Data").DataBodyRange(dataCount, "O").row - 1

    For i = 2 To dataLocation

        valueToCheck = dataSheet.ListObjects("Raw_Data").DataBodyRange(i, "O")
        If valueToCheck = checkOne Or valueToCheck = checkTwo Then
            'Errors out on the line below
            Worksheets("Raw Data").Range(Cells(i, "A"), Cells(i, "P")).Copy

            Worksheets("No Quality").Cells(Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row, 1).PasteSpecial
        End If

    Next i
    
End Sub

我可以让它部分运行，但它永远不会完成。我尝试使用以下代码，但我不确定如何更改它以按照我需要的方式运行。

Sub NoQuality()

    Dim dataTable As Range
    Dim newTable As Range

    Application.ScreenUpdating = False
    Set dataTable = Worksheets("Raw Data").ListObjects("Raw_Data").DataBodyRange
    Set newTable = Worksheets("No Quality").ListObjects("Phone_Number").DataBodyRange
    dataTable.Copy newTable.Offset(tbl2.Rows.Count)
    Application.CutCopyMode = False
    tbl1.ClearContents
    Application.ScreenUpdating = True

End Sub

新代码的结果

标签： excelvba

解决方案

您可能会使用更少的代码而侥幸逃脱。请尝试以下方法，让我知道情况如何。

Option Explicit
Sub Numbers()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Raw Data")
Set ws2 = Sheets("No Quality")

With ws1.ListObjects("Raw_Data").Range
    .AutoFilter 15, "No Quality", 2, "PH Phone"
    .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Cells(2, 1)
    .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
    ws1.ListObjects("Raw_Data").AutoFilter.ShowAllData
End With

End Sub

推荐阅读