Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление дубликатов макросом в Excel 2003
 
#1
14.10.2021 10:25:07
Здравствуйте. Есть макрос, главное проблема которую не могу решить, это что бы работало удаление дубликатов в 2003 Excel. Чем можно заменить RemoveDuplicates Columns который работает начиная с 2007 Excel?
Код
Sub B()
    Dim x As Object
    Dim Target As ListObject
    Set Target = ActiveWorkbook.Worksheets("B").ListObjects("B")
    
        Set x = BP("/sapi/history", "s=" + sym + "&limit=1000")
        For Z = 1 To x.Count
           Set lr = Target.ListRows.Add
            
            For c = 1 To x(1).Count
            
                    lr.Range(c) = x(Z)(Target.HeaderRowRange(c).Formula)
            Next c
        Next Z
    ActiveWorkbook.Worksheets("B").Range("B").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes
End Sub
Изменено: vikttur - 14.10.2021 10:25:41
 
 
 
#2
14.10.2021 10:41:21
Код
Sub myRemoveDuplicates(r As Range)
    Dim arr As Variant
    Dim brr As Variant
    arr = r
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim y As Long
    Dim u As Long
    Dim x As Integer
    Dim sKey As String
    For y = 1 To UBound(arr, 1)
        sKey = ""
        For x = 1 To UBound(arr, 2)
            sKey = sKey & arr(y, x)
        Next
        If Not dic.Exists(sKey) Then
            dic.Item(sKey) = 0
            u = u + 1
            For x = 1 To UBound(arr, 2)
                brr(u, x) = arr(y, x)
            Next
        End If
    Next
    r = brr
End Sub
 
 
 
#3
14.10.2021 11:54:18
Спасибо
Изменено: Sashat1705 - 14.10.2021 11:55:25
 
 
 
#4
17.10.2021 22:29:56
МатросНаЗебре, так и не смог запустить макрос в своем коде,  ошибку выкидывает, зато нашел  в  интернете универсальный макрос  который удаляет дубликаты сверяя их взявши за основу активный столбец, то есть щелкнув на ячейку  в  столбце.
Вопрос как можно подредактировать его так, что бы за  основу где перебирает дубликаты брал из активной рабочей книги-Лист1-столбец "M",  и  удалял не всю строку, так как правей идет еще  нужная мне информация которую не нужно удалять, а в пределах умной таблицы Таблица1?

Код
Public Sub DeleteDuplicateRows()
' This macro will delete all duplicate rows which reside under
' the first occurrence of the row.
'
'Use the macro by selecting a column to check for duplicates
'and then run the macro and all duplicates will be deleted, leaving
'the first occurrence only.

Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))

Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")

N = 0

For R = Rng.Rows.Count To 2 Step -1

    If R Mod 500 = 0 Then
    
        Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
    
    End If
    
    V = Rng.Cells(R, 1).Value
    
    If V = vbNullString Then
    
        If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
    
            Rng.Rows(R).EntireRow.Delete
    
            N = N + 1
    
        End If
    
    Else
    
        If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
    
            Rng.Rows(R).EntireRow.Delete
    
            N = N + 1
    
        End If
    
    End If

Next R

EndMacro:

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)

End Sub
 
 
 
#5
17.10.2021 22:56:14
Наверное, что-то типа такого

Код
Public Sub DeleteDuplicateRows()
    
    Dim R As Long, N As Long
    Dim V As Variant
    Dim Rng As Range
    Dim LO As ListObject
    
    On Error GoTo EndMacro
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Worksheets("Лист1").Activate
    Set LO = ActiveSheet.ListObjects(1)
    Set Rng = LO.DataBodyRange.Columns(13)
    Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")
    N = 0
    For R = LO.ListRows.Count To 2 Step -1
        If R Mod 500 = 0 Then
            Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
        End If
        V = Rng.Cells(R, 1).Value
        Rng.Cells(R, 1).Select
        If V = vbNullString Then
            If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
                LO.ListRows(R).Delete
                N = N + 1
            End If
        Else
            If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
                LO.ListRows(R).Delete
                N = N + 1
            End If
        End If
    Next R
    
EndMacro:
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub
 
 
 
#6
17.10.2021 23:17:31
New, Спасибо работает. С указанием книги листа и столбца понял, а вот как Вы сделали так, что бы удаление работало в пределах умной таблице, не могу понять.
 
 
 
#7
17.10.2021 23:42:45
Умная таблица - это отдельный объект на листе, у которого есть свои строки, столбцы, вот их и удаляем
Код
'присваиваем переменной LO умную таблицу, находящуюся на листе
Set LO = ActiveSheet.ListObjects(1)

Код
'а вот тут мы говорим - удалить строку номер, например, 10 Умной таблицы. Не 10-я строка листа, а 10-я строка Умной таблицы.
LO.ListRows(R).Delete '
Изменено: New - 17.10.2021 23:44:03
 
 
 
Страницы: 1
Наверх