朋友,
我有一个重复数千行的excel表。 3个类别的列,可能会重复,例如下面显示的第二行
是否有办法让excel在一行中循环并删除该行中的重复项,从而使其最终看起来像下面显示的第二张表?
我不确定,但这是您要尝试的吗?
Option Explicit
Sub Sample()
Dim wsI As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, j As Long
Dim sVal1, sVal2, sVal3
'~~> Input Sheet
Set wsI = Sheets("Sheet1")
With wsI
lastRow = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
lastCol = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, MatchCase:=False).Column
For i = 1 To lastRow
sVal1 = .Cells(i, 1).Value
sVal2 = .Cells(i, 2).Value
sVal3 = .Cells(i, 3).Value
For j = 4 To lastCol Step 3
If .Cells(i, j).Value = sVal1 And _
.Cells(i, j + 1).Value = sVal2 And _
.Cells(i, j + 2).Value = sVal3 Then
.Cells(i, j).ClearContents
.Cells(i, j + 1).ClearContents
.Cells(i, j + 2).ClearContents
End If
Next j
Next i
End With
End Sub
这是我为之解决的方法。不是最漂亮的,但它可以工作:
从行中删除重复的电话
Sub PhoneDedupByRow()
Dim Loopcounter As Long
Dim NumberOfCells As Long
Application.ScreenUpdating = False
'Range starting at A1
Worksheets("Sheet1").Activate
NumberOfCells = Range("A2", Range("A2").End(xlDown)).Count
For Loopcounter = 1 To NumberOfCells
'copies each section...I need to select the proper offsets for cells with the ph#'
Range(Range("A1").Offset(Loopcounter, 10), Range("A1").Offset(Loopcounter, 19)).Copy
'This is where the past/transpose will go...push it out to a far out column to avoid errors
Range("W1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
'Knowing the range is 10 cells, i added 11 because gotospecial with no blanks causes an error
Range("W1:W11").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("W1:W10").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("W1:W10").Select
Selection.Copy
Range(Range("A1").Offset(Loopcounter, 10), Range("A1").Offset(Loopcounter, 19)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
ActiveSheet.Range("W1:W10").Select
Selection.ClearContents
Next Loopcounter
Application.ScreenUpdating = True
End Sub