我遇到了从单行中删除重复项的问题。我想循环遍历某个范围内的所有行并从单行中删除重复项，而不影响工作表中的其余数据。以下是示例数据：
+---------------+------+------+------+---------------+---------------+
| name | num1 | num2 | mun3 | emial1 | email2 |
+---------------+------+------+------+---------------+---------------+
| ali zubair | 1 | 2 | 1 | [email protected] | [email protected] |
+---------------+------+------+------+---------------+---------------+
| tosif | 1 | 2 | 2 | [email protected] | [email protected] |
+---------------+------+------+------+---------------+---------------+
| qadeer satter | 3 | 2 | 3 | [email protected] | [email protected] |
+---------------+------+------+------+---------------+---------------+
| asif | 4 | 3 | 2 | | |
+---------------+------+------+------+---------------+---------------+
| hamid | 1 | 5 | 2 | [email protected] | [email protected] |
+---------------+------+------+------+---------------+---------------+
下面的代码根据第 2 列删除重复的行，但不适用于我的情况。
ActiveSheet.Range("A1:f100").RemoveDuplicates Columns:=Array(2), Header:=xlYes
我不知道如何从选定的行范围中删除重复项。到目前为止，我拥有可以循环遍历数据中所有行的代码。
Sub removeRowDubs()
Dim nextRang As Range
Dim sCellStr As String, eCellStr As String
Dim dRow As Long
dRow = Cells(Rows.Count, 1).End(xlUp).Row
For dRow = 2 To dRow
sCellStr = Range("A" & dRow).Offset(0, 1).Address
eCellStr = Cells(dRow, Columns.Count).End(xlToLeft).Address
Set nextRang = Range(sCellStr, eCellStr)
Debug.Print nextRang.Address
Next
End Sub
所以我需要的是一些代码来完成我需要在下面的代码后插入的操作。
Set nextRang = Range(sCellStr, eCellStr)
我希望我的问题已经说清楚了，非常感谢您的帮助。我是 Excel VBA 编码的新手，需要您的耐心。
我也研究了我的代码，代码如下。它对我来说是可行的，但是回答我问题的人提供了更好的代码。
Sub removeRowDuplicates()
Dim nextRang As Range ' Variables for
Dim sCellStr As String, eCellStr As String ' Going through all rows
Dim dRow As Long ' And selecting row range
dRow = Cells(Rows.Count, 1).End(xlUp).Row ' This code selects the
For dRow = 2 To dRow ' next row in the data
sCellStr = Range("A" & dRow).Offset(0, 1).Address
eCellStr = Cells(dRow, Columns.Count).End(xlToLeft).Address
Set nextRang = Range(sCellStr, eCellStr)
Dim aRange As Range, aCell As Range ' Variables for
Dim dubCheckCell As Range, dubCheckRange As Range ' Loops to remove
Dim dubCheckCell1 As Range ' Dublicates from
Dim columnNum As Integer ' Current row
Set aRange = nextRang
columnNum = Range("b2:f2").Columns.Count + 1
aRange.Select
For Each aCell In aRange 'Loop for selecting 1 cell, if not blank from range to check its value against all other cell values
If aCell.Value <> "" Then
Set dubCheckCell = aCell
Else
GoTo nextaCell 'If current cell is blank then go to next cell in range
End If
If dubCheckCell.Offset(0, 2).Value <> "" Then 'Selects range by offsetting 1 cell to right from current cell being checked for dublicate value
Set dubCheckRange = Range(dubCheckCell.Offset(, 1), dubCheckCell.Offset(, 1).End(xlToRight))
Else
Set dubCheckRange = Range(dubCheckCell.Offset(0, 1).Address)
End If
For Each dubCheckCell1 In dubCheckRange 'Loop that goes through all cells in range selected by above if-statement
Do While dubCheckCell1.Column <= columnNum
If dubCheckCell = dubCheckCell1 Then
dubCheckCell1.ClearContents
Else
End If
GoTo nextdubCheckCell1
Loop 'For do while
nextdubCheckCell1:
Next dubCheckCell1 'Next for dubCheckRange
nextaCell:
Next aCell 'Next for aRange
Next 'For drow
End Sub
答案1
我修改了宏以使用我自己的变量。宏首先获取行数和列数。然后循环遍历行、列和单元格并比较值。如果发现重复值，则将其替换为空值。
Sub removeRowDubs()
Dim dRow As Long
Dim dCol As Double
Dim i, j, k As Integer
Dim rng As Range
i = 1
dCol = 0
Set rng = Range(i & ":" & i)
'Get the rows
dRow = Cells(Rows.Count, 1).End(xlUp).Row
'Get the columns
dCol = WorksheetFunction.CountIfs(rng, "<>" & "")
'Contains the value to search
Dim cvalue As String
'Loop through the rows
For i = 2 To dRow
'Loop through the columns
For j = 2 To dRow
cvalue = Cells(i, j).Value
'Loop through the cells
For k = (j + 1) To dCol
If Cells(i, k).Value = cvalue Then
Cells(i, k).Value = ""
End If
Next
Next
Next
End Sub
单击放大 gif 图像来查看宏的运行情况。
答案2
您可以使用这样的循环：
Sub remdupes()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim MyArr As Variant
Dim x As Long, j As Long, n As Long
MyArr = Sheet8.Range("A1").CurrentRegion
For x = LBound(MyArr, 1) To UBound(MyArr, 1)
For j = LBound(MyArr, 2) To UBound(MyArr, 2) - 1
For n = j + 1 To UBound(MyArr, 2)
If UCase(MyArr(x, j)) = UCase(MyArr(x, n)) Then MyArr(x, n) = vbNullString
Next n
Next j
Next x
Sheet8.Range("A1").CurrentRegion = MyArr
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
如果您有与要删除重复项的区域相邻的数据，只需将 .currentregion 引用更改为您要编辑的范围。
答案3
我喜欢使用 Dictionary 对象来删除重复项。它快速、简单且易于理解。
我也更喜欢使用 VBA 数组，而不是重复读取/写入工作表。这通常会使例程速度提高 5-10 倍。（尽管数据量较少，实际差异可能微不足道。不过，这是一种习惯）。
下面对二者进行了演示。
Option Explicit
Sub remDupRows()
Dim WS As Worksheet, R As Range
Dim LR As Long, LC As Long
Dim vData As Variant
Dim I As Long, J As Long
Dim D As Object
'Set worksheet and data range
Set WS = ThisWorkbook.Worksheets("sheet10")
With WS
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set R = .Range(.Cells(1, 1), .Cells(LR, LC))
End With
'read data into variant array for faster processing
vData = R
'use dictionary for removing duplicates from each row
For I = 2 To UBound(vData, 1)
Set D = CreateObject("scripting.dictionary")
D.CompareMode = vbTextCompare 'case insensitive
For J = 1 To UBound(vData, 2)
If D.Exists(vData(I, J)) Then
vData(I, J) = ""
Else
D.Add vData(I, J), vData(I, J)
End If
Next J
Next I
'write the results back to the worksheet
'could overwrite the original data, but won't do that here
Set R = WS.Cells(LR + 2, LC + 2)
Set R = R.Resize(UBound(vData, 1), UBound(vData, 2))
With R
.Value = vData
.Style = "Output" 'not internationally aware
.EntireColumn.AutoFit
End With
End Sub
