☰

如何根据单列中的重复值删除工作表中的行

tag-icon • tag-icon microsoft-excel vba
如何根据单列中的重复值删除工作表中的行

因此，我有一个包含多个工作表的工作簿，根据复选框是否被选中，我抓取特定工作表上的数据（在下面的代码中，我有 3 个复选框，它们将根据是否被选中来抓取特定工作表上的数据）。每个工作表中的数据都被复制到已经存在的工作表（在本例中为“Landing Pad”）并添加到下一个空行。单击按钮时，我运行以下代码：

Public Sub CommandButton1_Click()

Dim r As Long
Dim rcnt As Long
Dim Dst As Worksheet


With ThisWorkbook

Set Dst = .Sheets("Landing Pad")
Dst.Cells.ClearContents
Sheets("Landing Pad").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete


'r = 2
rcnt = 1  ' stores amount of inserted rows

If Me.CheckBox1 = True Then
With .Sheets("IT Certification")
r = .Range("A" & .Rows.Count).End(xlUp).Row 
.Range("A1:D" & r).Copy _
Destination:=Dst.Range("A" & rcnt)
rcnt = rcnt + r 'lastrow
End With
End If

If Me.CheckBox2 = True Then
With .Sheets("Business Skills & Productivity")
r = .Range("A" & .Rows.Count).End(xlUp).Row 
.Range("A1:D" & r).Copy _
Destination:=Dst.Range("A" & rcnt)
rcnt = rcnt + r 
End With
End If

If Me.CheckBox3 = True Then
 With .Sheets("Database and Cybersecurity")
r = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:D" & r).Copy _
Destination:=Dst.Range("A" & rcnt)
rcnt = rcnt + r 
End With
End If

End With

End Sub

所有工作表都具有相同的结构（A：D），但其中一些在 D 列中有重复的值。我想要做的是仅根据某一特定列（D 列）的值复制行，以便该列中没有重复的值。

现在发生的情况如下：

Workbook1

A   B   C   D   
aa  ee  ii  zz  
bb  ff  jj  zz
cc  gg  kk  zz
dd  hh  ll  mm

        +

Workbook2

A   B   C   D
nn  pp  rr  tt
oo  qq  ss  uu

        =

New Workbook

A   B   C   D
aa  ee  ii  zz
bb  ff  jj  zz
cc  gg  kk  zz
dd  hh  ll  mm
nn  pp  rr  tt
oo  qq  ss  uu

以下是我希望发生的事情：

Workbook1

A   B   C   D   
aa  ee  ii  zz  
bb  ff  jj  zz
cc  gg  kk  zz
dd  hh  ll  mm

        +

Workbook2

A   B   C   D
nn  pp  rr  tt
oo  qq  ss  uu

        =

New Workbook

A   B   C   D
aa  ee  ii  zz
dd  hh  ll  mm
nn  pp  rr  tt
oo  qq  ss  uu

我不确定该怎么做...也许我可以将它们存储在一个变量中，而不是一次复制每个工作表，然后在添加完所有数据后使用 RemoveDuplicates 方法复制变量中的数据？或者这可能需要循环遍历每个选定的工作表？任何帮助都非常感谢！

答案1

编辑2- 第一个代码块被修改以与 Sheet 中的 ActiveX 控件配合使用。

  • 对于用户表单：取消注释掉的注释If ... Then ' UserForm并删除以下If行。

编辑1- 有关如何Const在第一个代码块后配置用户设置的详细信息。

我强烈鼓励使用第二个代码块。它消除了这个容易出错的临时解决方案，并且消除了复选框发生变化时修改代码的必要性（复选框的数量以及与复选框关联的目标工作表名称）。

复制不同

如果目的地在 D 列中应该有不同的值，则仅添加满足条件的行。

Option Explicit

Private Const distinctCol = "D"
Private Const firstCol = "A"
Private Const lastCol = "D"
Private Const destination = "Landing Pad"
Private Const checkboxSource = "CheckBox1, IT Certification; CheckBox2, Business Skills & Productivity; CheckBox3, Database and Cybersecurity"
Private Const separator1 = ", " ' Checkbox Name <separator1> Worksheet Name
Private Const separator2 = "; " ' 1st box&sheet <separator2> 2nd box&sheet

Private Sub CommandButton1_Click()
    Dim r As Long
    Dim distinct As Boolean
    Dim copiedRows As Long
    Dim copyRowCount As Long
    Dim copyRange As Range
    Dim copyDistinct As Range
    Dim Dws As Worksheet, Sws As Worksheet
    Dim checkBoxAndSource As Variant

    Set Dws = ThisWorkbook.Worksheets(destination)
    Dws.Cells.ClearContents
    Dws.Select
    On Error Resume Next
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0

    copiedRows = 0

    For Each checkBoxAndSource In Split(checkboxSource, separator2)
        'If Me(Split(checkBoxAndSource, separator1)(0)) Then ' UserForm
        If Me.OLEObjects(Split(checkBoxAndSource, separator1)(0)).Object Then
            Set Sws = ThisWorkbook.Worksheets(Split(checkBoxAndSource, separator1)(1))
            Set copyRange = Nothing
            Set copyDistinct = Nothing
            copyRowCount = 0
            For r = 1 To Sws.Range(distinctCol & Sws.Rows.Count).End(xlUp).Row
                distinct = True
                If copiedRows Then
                    distinct = Dws.Range(distinctCol & 1, distinctCol & _
                        copiedRows).Find(Sws.Cells(r, distinctCol)) Is Nothing
                End If
                If distinct And Not copyDistinct Is Nothing Then
                    distinct = copyDistinct.Find(Sws.Cells(r, distinctCol)) Is Nothing
                End If
                If distinct Then
                    If copyRowCount Then
                        Set copyRange = Union(copyRange, Sws.Range(firstCol & r, lastCol & r))
                        Set copyDistinct = Union(copyDistinct, Sws.Cells(r, distinctCol))
                    Else
                        Set copyRange = Sws.Range(firstCol & r, lastCol & r)
                        Set copyDistinct = Sws.Cells(r, distinctCol)
                    End If
                    copyRowCount = copyRowCount + 1
                End If
            Next r
            If Not copyRange Is Nothing Then
                copyRange.Copy destination:=Dws.Cells(copiedRows + 1, firstCol)
                copiedRows = copiedRows + copyRowCount
            End If
        End If
    Next checkBoxAndSource
End Sub

编辑：Const配置。

  • 他们三个Const，checkbox源，分隔符1和分隔符2 齐心协力。
  • 主要Const的是checkboxSource。
    • 这是复选框与其各自工作表名称关联的地方。
    • 数量可多可少，最少一个。
  • 它们Const separator仅用于分隔checkboxSource字符串。
    • 后面的注释描述了分隔符所分隔的内容。
    • checkboxSource如果字符串的形成方式如此，则分隔符应该在字符后面包含一个空格。
  • 所有这三个都是根据原始 OP 代码设置的，因此 OP 不需要更改任何内容。
  • 不对分隔符值进行硬编码的原因是,和都;可以在工作表名称中使用（尽管不应该这样）。

整个 CheckBox1→“工作表名称”有点混乱。

此实现使用表单的控件属性。

为了完成此代码的实现，请阅读此代码块后面有关配置表单控件属性的说明。

Option Explicit

Private Const distinctCol = "D"
Private Const firstCol = "A"
Private Const lastCol = "D"

Private Sub CommandButton1_Click()
    Dim r As Long
    Dim distinct As Boolean
    Dim copiedRows As Long
    Dim copyRowCount As Long
    Dim copyRange As Range
    Dim copyDistinct As Range
    Dim Dws As Worksheet, Sws As Worksheet
    Dim ctrl As Control

    Set Dws = ThisWorkbook.Worksheets(Me.CommandButton1.Tag)
    Dws.Cells.ClearContents
    Dws.Select
    On Error Resume Next
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0

    copiedRows = 0
    For Each ctrl In Me.Controls
      If TypeName(ctrl) = "CheckBox" Then
        If ctrl.GroupName = Me.CommandButton1.Tag Then
          If ctrl Then
            Set Sws = ThisWorkbook.Worksheets(ctrl.Tag)
            Set copyRange = Nothing
            Set copyDistinct = Nothing
            copyRowCount = 0
            For r = 1 To Sws.Range(distinctCol & Sws.Rows.Count).End(xlUp).Row
                distinct = True
                If copiedRows Then
                    distinct = Dws.Range(distinctCol & 1, distinctCol & _
                        copiedRows).Find(Sws.Cells(r, distinctCol)) Is Nothing
                End If
                If distinct And Not copyDistinct Is Nothing Then
                    distinct = copyDistinct.Find(Sws.Cells(r, distinctCol)) Is Nothing
                End If
                If distinct Then
                    If copyRowCount Then
                        Set copyRange = Union(copyRange, Sws.Range(firstCol & r, lastCol & r))
                        Set copyDistinct = Union(copyDistinct, Sws.Cells(r, distinctCol))
                    Else
                        Set copyRange = Sws.Range(firstCol & r, lastCol & r)
                        Set copyDistinct = Sws.Cells(r, distinctCol)
                    End If
                    copyRowCount = copyRowCount + 1
                End If
            Next r
            If Not copyRange Is Nothing Then
                copyRange.Copy destination:=Dws.Cells(copiedRows + 1, firstCol)
                copiedRows = copiedRows + copyRowCount
            End If
          End If
        End If
      End If
    Next ctrl
End Sub

这些是表单控件的属性设置

  • CommandButtonTag具有以下特点：
    • 这目标工作表名称（原帖：“着陆台”）和
    • CheckBox 的GroupName
  • CheckBoxTag是其源表名称 (OP: cb1.tag“IT 认证”)。
  • CheckBoxGroupName是其关联的 CommandButton Tag。
    （请参阅上面的 CommandButton Tag。这也是目标工作表名称。）
    • 该约定允许按钮与复选框相关联。
    • 它可以防止表单的其他复选框被纳入操作。

答案2

这段小代码应该可以帮你完成。
请参阅“子测试”了解如何调用“delDoubleRow”。

Private Sub delDoubleRow(aSht As Worksheet, aCol As String)
Dim rx As Long
Dim lastrow As Long

lastrow = aSht.Range(aCol & aSht.Rows.Count).End(xlUp).Row
For rx = lastrow To 1 Step -1  'count backwards from last to keep next row(rx) valid!
  If WorksheetFunction.CountIf(aSht.Range(aCol & "1" & ":" & aCol & rx), aSht.Range(aCol & rx)) > 1 Then
    aSht.Rows(rx).EntireRow.Delete
  End If
Next
End Sub

Public Sub Test()
delDoubleRow ThisWorkbook.Sheets("Landing Pad"), "D"
End Sub

答案3

我想建议这个 VBA 代码（宏），它将帮助您根据 D 列中的重复值删除整行/行。

Sub RemoveDuplicatesCells_EntireRow()


Dim rng As Range
Dim x As Integer

Sheets("LandingPad").Activate 
Set rng = Sheets("LandingPad").Range("A:D")
Range("A:D").Select


  Application.ScreenUpdating = False


  On Error GoTo InvalidSelection
  Set rng = Selection
  On Error GoTo 0


  On Error GoTo InputCancel
    x = InputBox("Which Column Should Look For Duplicates? (Number only!)", _
      "Select A Column", 1)
  On Error GoTo 0


  Application.Calculation = xlCalculationManual


  rng.EntireRow.RemoveDuplicates Columns:=x

  Application.Calculation = xlCalculationAutomatic

  With ActiveSheet
    .EnableSelection = xlNoSelection
  End With

 Application.CutCopyMode = False


Exit Sub


InvalidSelection:
  MsgBox "You selection is not valid", vbInformation
  Exit Sub

InputCancel:

End Sub

怎么运行的：

  • 复制&粘贴此代码着陆垫垫作为标准模块。
  • 在您用来将数据从不同工作表复制到的代码中的Call RemoveDuplicatesCells_EntireRow最后一个语句之前激活此宏使用语句。End WithLanding Pad Sheet
  • 使用此命令行调用宏。

Call LandingPad.RemoveDuplicatesCells_EntireRow

  • 回应输入框用适当的列号，就您而言4是D。

相关内容