Question

我正在处理一个循环，该循环将馈入工作表“结果”中的单元格并遍历工作表数（目前设置为1-3），并删除从工作表“结果”中找到值的行”。目前失败，请您指教？

Sub Del_Rows()

Dim rng As Range, cell As Range, del As Range
Dim sht As Worksheet

For x = 1 To 3
    Set sht = Sheets(x)
    Set del = Sheets("Results").Range("A13")

    Set rng = Intersect(sht.Range("A1:A2000"), sht.UsedRange)
    For Each cell In rng.Cells
    If (cell.Value) = Sheets("Results").Range("A13") Then 
        If del Is Nothing Then
            Set del = cell
        Else
            Set del = Union(del, cell)
        End If
    End If
    Next cell

    If del Is del Then del.EntireRow.Delete

Next x

End Sub

此外，我知道这样做可能要复杂得多，但是代码是否有可能一一看待sheet（“ Results”）中的动态范围？

我的意思是该代码获取Sheets（“ Results”）。Range（“ A13”）的值，并在工作表1-3中搜索找到的值，并在找到行时删除行，然后将其移至Sheets（“ Results”） .Range（“ A14”）并执行相同的操作。

由于[Sheets（“ Results”）。Range（“ A13”）+最后一行]中的数据是动态的，因此它只做相同的事情，直到到达末尾为止（例如Sheets（“ Results”）。Range（“ A20”）。

非常感谢

Answer 1

我没有测试代码，因此可能存在语法错误或错字。

Dim wb as workbook
Set wb = ActiveWorkbook
set rsws = wb.worksheets("Results")
dim lastResult as Long
lastResult = rsws.Usedrange.SpecialCells(xlCelltypeLastcell).Row 'count the last row of ResultSheet.
dim lastrowCheck as Long

for each ws in wb.worksheets 'loop through each worksheet
  lastrowCheck = ws.Usedrange.SpecialCells(xlCelltypeLastcell).Row
  if ws.name <> "Results" then
     for i = 1 to lastResult 'loop through each Result range cell
        for j = 1 to lastrowCheck  'loop throught and check value
           if rsws.cells(i,13) <> vbNullString then
                if rsws.cells(i,13) = ws.cells(j,1) then 'I suppose that it's in the first column.
            'your deleting code here
                end if
            end if
         next j
     next i
  end if
next ws

下面是我的excel中的实际代码，其中包括一些调试打印内容。

Sub testtesttest()
Dim wb As Workbook
Set wb = ActiveWorkbook
Set rsws = wb.Worksheets("Results")
Dim lastResult As Long
lastResult = rsws.UsedRange.SpecialCells(xlCellTypeLastCell).Row 'count the last row of ResultSheet.
Dim lastrowCheck As Long

For Each ws In wb.Worksheets 'loop through each worksheet
  lastrowCheck = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
  Debug.Print "lastrowCheck "; lastrowCheck
  Debug.Print ws.name
  If ws.name <> "Results" Then
     For i = 1 To lastResult 'loop through each Result range cell
        For j = 1 To lastrowCheck  'loop throught and check value
           If rsws.Cells(i, 13) = ws.Cells(j, 1) Then 'I suppose that it's in the first column.
            'your deleting code here
             Debug.Print "good good good"
            End If
         Next j
     Next i
  End If
Next ws

End Sub

Answer 2

我设法处理了我的初始代码，并提出了以下解决方案，该解决方案对我来说很有效。

Public Sub Loop_DEL()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------------------------------------------------------------
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'----------------------------------------------------------------------
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range, rng7 As Range, rng8 As Range, c As Range
Dim rngToDel2 As Range, rngToDel3 As Range, rngToDel4 As Range, rngToDel5 As Range, rngToDel6 As Range, rngToDel7 As Range, rngToDel8 As Range
Dim lastRow As Long

With Worksheets("Results")
   lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   Set rng1 = .Range("A3:A" & lastRow)
End With

Set rng2 = Worksheets("ANY SCORE").Range("A:A")
Set rng3 = Worksheets("Page1").Range("A:A")
Set rng4 = Worksheets("Page2").Range("A:A")
Set rng5 = Worksheets("Page3").Range("A:A")
Set rng6 = Worksheets("Page4").Range("A:A")
Set rng7 = Worksheets("Page5").Range("A:A")
Set rng8 = Worksheets("Page6").Range("A:A")

For Each c In rng2
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel2 Is Nothing Then
   Set rngToDel2 = c
   Else
   Set rngToDel2 = Union(rngToDel2, c)
End If
End If
   Next c
   If Not rngToDel2 Is Nothing Then rngToDel2.EntireRow.Delete

For Each c In rng3
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel3 Is Nothing Then
   Set rngToDel3 = c
   Else
   Set rngToDel3 = Union(rngToDel3, c)
End If
End If
   Next c
   If Not rngToDel3 Is Nothing Then rngToDel3.EntireRow.Delete

For Each c In rng4
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel4 Is Nothing Then
   Set rngToDel4 = c
   Else
   Set rngToDel4 = Union(rngToDel4, c)
End If
End If
   Next c
   If Not rngToDel4 Is Nothing Then rngToDel4.EntireRow.Delete

For Each c In rng5
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel5 Is Nothing Then
   Set rngToDel5 = c
   Else
   Set rngToDel5 = Union(rngToDel5, c)
End If
End If
   Next c
   If Not rngToDel5 Is Nothing Then rngToDel5.EntireRow.Delete

For Each c In rng6
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel6 Is Nothing Then
   Set rngToDel6 = c
   Else
   Set rngToDel6 = Union(rngToDel6, c)
End If
End If
   Next c
   If Not rngToDel6 Is Nothing Then rngToDel6.EntireRow.Delete

For Each c In rng7
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel7 Is Nothing Then
   Set rngToDel7 = c
   Else
   Set rngToDel7 = Union(rngToDel7, c)
End If
End If
   Next c
   If Not rngToDel7 Is Nothing Then rngToDel7.EntireRow.Delete

For Each c In rng8
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel8 Is Nothing Then
   Set rngToDel8 = c
   Else
   Set rngToDel8 = Union(rngToDel8, c)
End If
End If
   Next c
   If Not rngToDel8 Is Nothing Then rngToDel8.EntireRow.Delete

SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

遍历范围，然后根据单元格值进行工作表并删除行

2 个答案: