在Excel中查找重复值并使用VBA将行导出到另一个工作表

2 回答

• 2

  edit ：添加了另一个替代代码（参见"2nd code"），它应该更快，更快

  尝试这些优化

  第一个代码：

  Option Explicit
  
  Sub FilterAndCopy()
  
  Dim wstSource As Worksheet, _
      wstOutput As Worksheet
  Dim rngMyData As Range, _
      helperRng As Range
  
  Set wstSource = Worksheets("Sheet1")
  Set wstOutput = Worksheets("Sheet2")
  
  Application.ScreenUpdating = False
  
  With wstSource
      Set rngMyData = .Range("A1:D" & .Range("A" & .Rows.Count).End(xlUp).Row)
  End With
  Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
  
  With helperRng
      .FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)"
      .Value = .Value
      .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(1, 1)
      .ClearContents
  End With
  
  Application.ScreenUpdating = True
  
  End Sub
  

  “第二代码”

  Option Explicit
  
  Sub FilterAndCopy2()
  
  Dim wstSource As Worksheet, _
      wstOutput As Worksheet
  Dim rngMyData As Range, _
      helperRng As Range, _
      unionRng As Range
  Dim i As Long, iOld As Long
  
  Set wstSource = Worksheets("Sheet1")
  Set wstOutput = Worksheets("Sheet2")
  
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  With wstSource
      Set rngMyData = .Range("A1:D" & .Range("A" & .Rows.Count).End(xlUp).Row)
  End With
  
  With rngMyData
      Set helperRng = .Offset(, rngMyData.Columns.Count - 1).Resize(, 1)
      Set unionRng = .Cells(1000, 1000) 'set a "helper" cell to be used with Union method, to prevent it from failing the first time
  End With
  
  With helperRng
      .FormulaR1C1 = "=row()" 'mark rows with ad ascending number (its own row number)
      .Value = .Value
  End With
  
  With rngMyData.Resize(, rngMyData.Columns.Count + 1) 'enclose "helper" column
      .Sort key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data to have all same columnA values grouped one after another
      i = .Rows(1).Row 'start loop from data first row
      Do While i < .Rows(.Rows.Count).Row
          iOld = i 'set current row as starting row
          Do While .Cells(iOld + 1, 1) = .Cells(iOld, 1) 'loop till first cell with different value
              iOld = iOld + 1
          Loop
  
          If iOld - i > 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
          i = iOld + 1
      Loop
      Intersect(unionRng, rngMyData).EntireRow.Copy Destination:=wstOutput.Cells(1, 1) 'get rid of the "helper" cell via Intersect method
      wstOutput.Columns(helperRng.Column).Clear 'delete "Helper" column pasted in wstOutput sheet
      .Sort key1:=.Columns(4), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data in wstSource back
  End With
  helperRng.Clear 'delete "helper" column, not needed anymore
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  
  End Sub
  

  回复于 2024-04-29T23:23:38+08:00
• 4

  有很多方法可以做到这一点 . 为了使它更简单，我尝试仅改变你的循环 . PFB更改的代码 -

  For Each rngCell In rngMyData
  '''    If Evaluate("COUNTIF(" & rngMyData.Address & "," & rngCell.Address & ")") > 1 Then
  '''        lngMyRow = wstOutput.Cells(Rows.Count, "A").End(xlUp).Row + 1
  '''        wstSource.Range("A" & rngCell.Row & ":D" & rngCell.Row).Copy _
  '''            Destination:=wstOutput.Range("A" & lngMyRow & ":D" & lngMyRow)
  '''    End If
  
     If WorksheetFunction.CountIf(rngMyData, rngCell.Value) > 1 Then
  
          wstOutput.Range("A100000").End(xlUp).Offset(1, 0).EntireRow.Value = rngCell.EntireRow.Value
  
     End If
  
  
  Next rngCell
  

  回复于 2024-04-29T23:23:38+08:00