VBA更快地清理數據

Question

我正在研究Sub，以幫助清理每周需要使用的大數據集。 數據是產品列表，每個產品都有總計和尺寸，因此看起來像這樣：

產品1全部

產品1小

產品1中

產品2全部

我只想保留符合以下3個條件之一的產品，但如果符合，我想保留該產品的所有行。 如果某個產品不符合這3個條件中的任何一個，我想刪除包含該產品的每一行。

我編寫了以下代碼，該代碼似乎確實有效，但是需要花費一些時間。

For i = Data.Cells(Rows.Count, "B").End(xlUp).Row To 3 Step -1
If Data.Range("F" & i) = "All" Then

    TY_Sales = Data.Range("K" & i)
    LY_Sales = Data.Range("L" & i)
    TY_Stock = Data.Range("O" & i)
    Sales_Stock = TY_Sales + LY_Sales + TY_Stock

    If Sales_Stock <= 0 Then
    vendor_ref = Data.Range("E" & i)
        For j = i + 10 To i Step -1
            If Data.Range("E" & j) = vendor_ref Then
            Data.Range("E" & j).EntireRow.Delete
            End If
        Next
    End If
End If
Next

因為我的原始數據集為17,000行，所以它花了很長時間，而且我知道我要一遍又一遍地遍歷它，但是我不知道有一種更快地完成它的更好方法。 任何幫助是極大的贊賞。

Answer 1

我的一般建議是創建一個字典，該字典是可以使用有序索引號或名稱鍵訪問的值的數組。 使用該字典，首先要遍歷所有數據行。 查看E列：詞典中是否還存在“ E”和i中的名稱？ 如果不是，請將其添加到詞典中。 然后獲取字典ID（新創建的字典ID，或在上一行創建的字典ID），然后將包含K，L和O列的行添加到字典條目的值中。

然后，一旦您用字典收集了所有名稱，並累加了K，L和O列，就可以從下往上瀏覽所有行。 對於該行的索引ID，字典條目中的值是否> 0？ 如果是，請刪除該行。

但是要使事情復雜化，您需要添加一個單獨的（免費的，Microsoft支持的）腳本包來使用Dictionary。 因此，我們將自己做。 唯一的意思是，每次檢查新行的唯一名稱時，我們都需要循環瀏覽到目前為止的唯一名稱列表，並逐個檢查每個名稱，而不是將該名稱用作索引。 請參閱下面的我的修訂代碼，以及對您所做更改的評論。 請注意，我在開始時設置了所有變量，包括將Data聲明為= sheets（1），這可能與您的子項不同。

Sub Delete_Unnecessary_Rows()

Dim i As Integer
Dim TY_Sales As Long, LY_Sales As Long, TY_Stock As Long, Sales_Stock As Long, LastRow As Long
Dim data As Worksheet
Dim vendor_ref As String

Dim VendorStringArray() As String 'This Array will hold all unique vendor names
Dim VendorNumArray() As Long 'This array will hold the Sales Stock value for each unique vendor name
Dim VendorRowIdentifier() As Long 'For each row, this will hold the index for particular unique vendor name
Dim UniqueNameCounter As Long 'This will hold the number of confirmed unique names

Dim UniqueCheck As Boolean


Set data = Sheets(1)

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

ReDim VendorStringArray(3 To LastRow) 'resize the array to be the full possible amount of unique string values
ReDim VendorNumArray(3 To LastRow)
ReDim VendorRowIdentifier(3 To LastRow)

For i = 3 To LastRow 'new loop to find new dictionary names
    If data.Range("F" & i) = "All" Then 'This is a data row to be searched for a unique vendor name

        UniqueCheck = True 'Holds TRUE until a duplicate value is found in a higher row

        vendor_ref = data.Range("E" & i).Formula 'Grabs the vendor name and Sales_Stock amount for that row
        TY_Sales = data.Range("K" & i)
        LY_Sales = data.Range("L" & i)
        TY_Stock = data.Range("O" & i)
        Sales_Stock = TY_Sales + LY_Sales + TY_Stock
        If UniqueNameCounter > 0 Then 'If there's already been at least 1 unique name, check prior unique names to try and find a match

            For j = UniqueNameCounter To 1 Step -1 'works backwards through prior unique counters to find a match
                If vendor_ref = VendorStringArray(j + 2) Then
                    UniqueCheck = False 'A match has been found
                    VendorRowIdentifier(i) = j + 2 'associates the row being searched with the index of the unique vendor name for the matched row
                    VendorNumArray(VendorRowIdentifier(i)) = VendorNumArray(VendorRowIdentifier(i)) + Sales_Stock 'adds the new sales stock value to the old one with that unique vendor name
                    j = 0 'stops the formula from looping after a match is found

                End If
            Next j
        End If
        If UniqueCheck Then 'no match was found for that name in an above row
                UniqueNameCounter = UniqueNameCounter + 1
                VendorStringArray(UniqueNameCounter + 2) = vendor_ref 'adds the text to be matched against future values in the array, starting at 3 instead of 1
                VendorRowIdentifier(i) = UniqueNameCounter + 2 'associates the row being searched with the index of the unique vendor name
                VendorNumArray(UniqueNameCounter + 2) = Sales_Stock
        End If
    End If

Next i


For i = LastRow To 3 Step -1 'After determining which rows have values, delete all such rows
    If data.Range("F" & i) = "All" Then
        If VendorNumArray(VendorRowIdentifier(i)) > 0 Then 'Pull the value of the unique vendor name associated with that row #'s vendor and check the size associated
            data.Rows(i).Delete 'Delete the row if any value has been assigned to that vendor
        End If
    End If
Next


End Sub

如Trey博士所建議，您還可以在處理過程中消除自動更新等操作，以進一步節省操作時間。

Answer 2

這是另一種方法。 此方法不是手動循環並檢查匹配的供應商名稱中的值，而是使用每行上的本機Excel SUMIFS函數來查看是否有任何匹配的行具有值。 然后通過布爾值數組為每一行分配TRUE或FALSE。 然后再次執行循環，並刪除標記為TRUE的行。 盡管使用SUMIFS可能比上面的手動循環更密集，但是此方法僅循環遍歷所有2x行。 但是我相信這種方法更容易理解。

披露：我已經測試了這兩種方法並確認它們都可以使用，但是不確定處理時間會有什么不同。

Sub CheckDelete_WithSumifs()

Dim i As Integer
Dim TY_Sales As Long, LY_Sales As Long, TY_Stock As Long, Sales_Stock As Long, LastRow As Long
Dim data As Worksheet
Dim Vendor_Ref As String
Dim DeleteRowCheck() As Boolean

Set data = Sheets(1)

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

ReDim DeleteRowCheck(3 To LastRow) 'resize the array to be the full possible amount of unique string values

For i = LastRow To 3 Step -1  'new loop to find new dictionary names
    If data.Range("F" & i) = "All" Then 'Only check to delete if the word All is in column F

        Vendor_Ref = data.Range("E" & i).Formula 'Grabs the vendor name and Sales_Stock amount for that row
        TY_Sales = GrabSumifs(data.Range("K:K"), Vendor_Ref, data) ' See function below
        LY_Sales = GrabSumifs(data.Range("L:L"), Vendor_Ref, data)
        TY_Stock = GrabSumifs(data.Range("O:O"), Vendor_Ref, data)

        Sales_Stock = TY_Sales + LY_Sales + TY_Stock 'Total value of all columns K, L, O for that vendor name

        If Sales_Stock > 0 Then
            DeleteRowCheck(i) = True 'Used in the loop below to define whether to delete the row
        Else
            DeleteRowCheck(i) = False
        End If
    End If

Next i

For i = LastRow To 3 Step -1 'After determining which rows have are marked TRUE to delete, delete those rows
    If DeleteRowCheck(i) Then
        data.Rows(i).Delete 'Delete the row if any value has been assigned to that vendor
    End If
Next


End Sub

Function GrabSumifs(SumRange, Vendor_Ref, data) As Long

'This function uses the SUMIFS formula native to Excel, to check the given column to see if any values are present with an identicial vendor name & "All" in column F.
GrabSumifs = Application.WorksheetFunction.SumIfs(SumRange, data.Range("F:F"), "All", data.Range("E:E"), Vendor_Ref)

End Function