VBA – 使用數據范圍刪除行

Question

我正在嘗試根據主表中的一系列數據從多個 Excel 文件中刪除行。 我只能逐行工作。 VBA 遍歷文件夾但無法正確引用列表。 我想將 Sub DeleteRowsBasedonCellValue 更改為基於主表數據而不是逐行刪除行。

`

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)
    
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
    
    'Change First Worksheet's Background Fill Blue
      Call DeleteRowsBasedonCellValue
    
    'Save and Close Workbook
      wb.Close SaveChanges:=True
      
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Sub DeleteRowsBasedonCellValue()

'Declare Variables
Dim LastRow As Long, FirstRow As Long
Dim Row As Long

With ActiveSheet
    'Define First and Last Rows
    FirstRow = 1
    LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

    'Loop Through Rows (Bottom to Top)
    For Row = LastRow To FirstRow Step -1
        If .Range("A" & Row).Value = "16.12.22" And .Range("C" & Row).Value = "FLL12T" Then
        .Range("A" & Row).EntireRow.Delete
        End If
    Next Row
End With

End Sub

`

Answer 1

不確定您所說的“主表數據”是什么意思，但我會將您的 DeleteRowsBasedonCellValue 代碼更改為此，以便通過將所有相關行放入一個范圍變量中來使其更快，然后一次刪除它。 請注意我對變量所做的更改。

Sub DeleteRowsBasedonCellValue()

    'Declare Variables
    Dim LastRow As Long
    Dim FirstRow As Long
    Dim lRow As Long '(Don't use "Row" because it is a reserved word)
    Dim rDelete As Range
    
    With ActiveSheet

        'Define First and Last Rows
        FirstRow = 1

        LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
    
        'Loop Through Rows (Bottom to Top)
        For lRow = LastRow To FirstRow Step -1
        
            If .Range("A" & lRow).Value = "16.12.22" And .Range("C" & lRow).Value = "FLL12T" Then
            
                If rDelete Is Nothing Then
            
                    Set rDelete = .Range("A" & lRow)
                    
                Else
                
                    Set rDelete = Union(rDelete, .Range("A" & lRow))
                
                End If
                            
            End If
            
        Next lRow
        
        If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
        
    End With

End Sub