Премахване на дублиращи се клетки в ред

Само за пояснение: не искам да премахвам дублиращи се редове, искам да премахвам дублиращи се клетки в ред

И така, ето класическа таблица с адреси и в някой ред има дублиращи се записи, които трябва да премахна. Повечето от това, което съм виждал във VBA, се използва за премахване на дублиращи се стойности в колона, но не мога да намеря начин да премахна дублирани стойности в ред.

Name  |        Address1 |       Address2 |    City |    Country

Peter | 2 foobar street |2 foobar street |  Boston |    USA

И искам да е така:

Name  |         Address1 |  Address2 |   City  |    Country

Peter | 2 foobar street  |           |  Boston |    USA

Написах макрос, който ще премине през всички редове и след това през всяка колона за всеки ред, но нямам представа как да забележа дубликат в различните клетки в рамките на същия ред.

ето кода по-долу:

Sub Removedupe()   
   Dim LastRow As Long
   Dim LastColumn As Long
   Dim NextCol As Long

   LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row    
   LastColumn = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

   For counterRow = 1 To LastRow               
       'I'm stuck here: how to remove a duplicate values within that row?         
   Next counterRow   
End Sub

duplicates excel row vba
person user3353255    schedule 27.02.2014    source източник

Отговори (4)


arrow_upward
3
arrow_downward

Може би това ще реши проблема ви:

Sub RemoveDuplicatesInRow()

    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long 'row index
    Dim c As Long 'column index
    Dim i As Long

    With ActiveSheet.UsedRange
        lastRow = .Row + .Rows.Count - 1
        lastCol = .Column + .Columns.Count - 1
    End With

    For r = 1 To lastRow
        For c = 1 To lastCol
            For i = c + 1 To lastCol 'change lastCol to c+2 will remove adjacent duplicates only
                If Cells(r, i) <> "" And Cells(r, i) = Cells(r, c) Then
                    Cells(r, i) = ""
                End If
            Next i
        Next c
    Next r

End Sub
person Hongen    schedule 28.02.2014
comment
Това го прави!! Опитах се да поставя всички стойности в масив, но вашият скрипт в края беше много по-бърз и по-малко сложен!! Благодаря за помощта - person user3353255; 01.03.2014

arrow_upward
0
arrow_downward

Може би това във вашия цикъл:

If Range("A1").Offset(counterRow,1) = Range("A1").Offset(counterRow,2) Then
    Range("A1").Offset(counterRow,2).Clear
End If
person andy holaday    schedule 27.02.2014

arrow_upward
0
arrow_downward

Вероятно най-лесно би било с речник. Прочетете текущата клетка. Ако вече е в речника, изчистете клетката, в противен случай го добавете към речника.

Dim dict As New Scripting.Dictionary 
For counterRow = 1 To LastRow         
   key = // get the current cell value
   If Not dict.Exists(key) Then 
       dict.Add key, "1"
   Else
      // clear current cell
End If Next counterRow

Повече за речника тук: VBA има ли речникова структура?

PS: Обърнете внимание, че моето решение премахва всички дубликати, а не само ако са във 2-ра и 3-та колона, както във вашия пример.

person Mitja Bezenšek    schedule 27.02.2014

arrow_upward
0
arrow_downward

Във вашия случай дубликатите са съседни. За да изчистите дубликати в една колона или един ред за този специален случай:

Sub qwerty()
    Dim r As Range, nR As Long
    Set r = Intersect(Cells(13, 1).EntireRow, ActiveSheet.UsedRange)
    nR = r.Count
    For i = nR To 2 Step -1
        If r(i) = r(i - 1) Then
            r(i) = ""
        End If
    Next i
End Sub

Този код е пример за ред #13

person Gary's Student    schedule 28.02.2014