помогите пож-та с макросом

[zakushka]

поставщик дает таблицу, в "N" столбцов

Необходимо произвести анализ: найти в столбце "C" строки с одинаковым значением и если по ним в столбце "D" указано одинаковое значение, то перемещать эти строки в соседний (новый) лист. пустые строки после переноса удалять

прошу извинить. если были такие темы. навскидку не нашел

[kalbasiatka]

Где эта таблица? Искать во всём столбце "С" с 1й по последнюю ячейку на листе? Что за значения в "D" и "C" - циферы, текст? Перемещать и удалять по 2 одинаковые строки? А, если будет 3 одинаковых, но 2 уже перенесли и удалили 3-я остаётся?

[zakushka]

приложил образец таблички. строк сейчас до тысячи, может быть до трёх тысяч, надо переносить все строки с удовлетворяющими параметрами счейки в столбце "C" равны и ячейки в "D" равны. Повторятся может значительно больше 2-3 раз. Во всех остальных случаях оставлять
Столбец "C" - текст (номер ордера с префиксами)
Столбец "D" - номер строки в ордере. приходит в текстовом.

[kalbasiatka]

Сделал без массивов, вроде работает.

Sub uuu()
    Dim i&, ii&, rw&, j&
    Dim sd As Object
    Dim x
    Application.ScreenUpdating = False
    rw = 2
    With Sheets("Open Items")
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        Set sd = CreateObject("Scripting.Dictionary")
        For i = 2 To lr
            sd.Item(i) = ""
            For ii = i + 1 To lr
                If .Cells(i, 3) = .Cells(ii, 3) And .Cells(i, 4) = .Cells(ii, 4) Then
                    sd.Item(ii) = ii
                End If
            Next
            If sd.Count > 1 Then
                For Each key_ In sd.Keys
                    .Range(.Cells(key_, 1), .Cells(key_, 16)).Copy Sheets("Лист1").Cells(rw, 1)
                    rw = rw + 1
                Next
                x = sd.Keys
                For j = UBound(x) To 0 Step -1
                    .Rows(x(j)).Delete
                Next
                lr = lr - sd.Count
                i = i - 1
            End If
            sd.RemoveAll
        Next
    End With
    Application.ScreenUpdating = True
End Sub

[Step_UA]

Так должно быть быстрее

Public Sub Duplicates()
  Dim Dic As Object, R As Range, row&, Mas, tmp$, i&
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.comparemode = 1
    Mas = Range(Cells(2, 3), Cells(Rows.Count, 4).End(xlUp)).Value
    For row = 1 To UBound(Mas)
        tmp = Mas(row, 1) & "|" & Mas(row, 2)
        If Dic.exists(tmp) Then
            i = Dic(tmp)
            If i Then
                If R Is Nothing Then Set R = Cells(i + 1, 1) Else Set R = Application.Union(R, Cells(i + 1, 1))
                Dic(tmp) = 0
            End If
            Set R = Application.Union(R, Cells(row + 1, 1))
        Else
            Dic(tmp) = row
        End If
    Next
    If Not R Is Nothing Then
        Rows(1).Copy
        Sheets.Add
        Cells(1, 1).PasteSpecial
        With R.EntireRow
            .Copy ActiveSheet.Cells(2, 1)
            .Delete
        End With
    End If
End Sub

[zakushka]

привет, оба варианта работают, один недостаток, пустые строки после переноса не убирают, можно докрутить? а то девочки, которые это будут делать, могут не убрать

[kalbasiatka]

У меня строки убирались

 .Rows(x(j)).Delete

[Step_UA]

А где Вы указывали о такой необходимости?