Cумма дубликатов на другой лист

[notekmk]

Здравствуйте, помогите сделать макрос, который выведет количество повторений одинаковых строк у которых есть атрибут "ДСП16", и удалит не нужные строки.
пробовал сделать это авто фильтром, но очень долго.

[staniiislav]

выкладывайте пример файла и опишите в самом фале что вы хотите чтобы получилось

[notekmk]

Книга4.rar
В архиве файл екселя

[staniiislav]

можно так попробовать:

Option Explicit

Sub сумма_дубликатов()
    Dim arr, arr2, arr3, i&, j&, n&, c$, c2$
    
    Application.ScreenUpdating = False
    
    Range("A11:H" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    With Sheets("2")
        arr = Range(.[S2], .Range("AC" & .Rows.Count).End(xlUp)).Value
    End With

    With New Collection
        On Error Resume Next
        For i = 1 To UBound(arr)
            If arr(i, 4) = "м2" Then
            .Add arr(i, 5) & "|" & arr(i, 8) & "|" & arr(i, 11) & "|" _
                    & arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 1) & "|" & arr(i, 2), _
                    CStr(arr(i, 5) & "|" & arr(i, 8) & "|" & arr(i, 11) & "|" _
                    & arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 1) & "|" & arr(i, 2))
            If Err = 0 Then
                n = n + 1
                arr(n, 1) = arr(i, 5)
                arr(n, 2) = arr(i, 8)
                arr(n, 3) = arr(i, 11)
                arr(n, 4) = arr(i, 6)
                arr(n, 5) = arr(i, 7)
                arr(n, 6) = arr(i, 1)
                arr(n, 7) = arr(i, 2)
            Else: Err.Clear
            End If
            End If
        Next i
        On Error GoTo 0
    End With
    If n Then [A11].Resize(n, 7).Value = arr
    
    With Sheets("2")
        arr = Range(.[S2], .Range("AC" & .Rows.Count).End(xlUp)).Value
    End With
    
    arr2 = Range("A11:H" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    arr3 = Range("A11:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    n = 0
        For j = 1 To UBound(arr2)
            c = arr2(j, 1) & "|" & arr2(j, 2) & "|" & arr2(j, 3) & "|" _
                & arr2(j, 4) & "|" & arr2(j, 5) & "|" & arr2(j, 6) & "|" & arr2(j, 7)
            For i = 1 To UBound(arr)
                c2 = arr(i, 5) & "|" & arr(i, 8) & "|" & arr(i, 11) & "|" _
                    & arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 1) & "|" & arr(i, 2)
                If c = c2 Then
                    n = n + 1
                End If
            Next i
        arr3(j, 1) = n
        n = 0
        Next j
        
    [H11].Resize(UBound(arr2)).Value = arr3
    Application.ScreenUpdating = True

End Sub

[nilem]

вариант (записано макрорекордером)

Sub ertert()
Sheets("ДСП").UsedRange.ClearContents
With Sheets("2")
    .AutoFilterMode = False
    With .Range("A1:Z" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .AutoFilter Field:=26, Criteria1:="ДСП16"
        Union(.Columns("S:T"), .Columns("W:Z"), .Columns("AC")).Copy Sheets("ДСП").Range("A1")
        .AutoFilter
    End With
End With
With Sheets("ДСП").Range("A1").CurrentRegion
    .Columns(.Columns.Count + 1).FormulaR1C1 = _
    "=CONCATENATE(RC[-7],RC[-6],RC[-5],RC[-4],RC[-3],RC[-2],RC[-1],)"
    .Columns(.Columns.Count + 2).FormulaR1C1 = _
    "=COUNTIF(R1C8:R" & .Rows.Count & "C8,RC[-1])"
    With .Columns(.Columns.Count + 1).Resize(, 2)
        .Value = .Value
    End With
    .CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9), _
                                    Header:=xlYes
    .Columns(.Columns.Count + 1).Delete
End With
End Sub

[notekmk]

импортИзСкетча вопрос.rarу меня при выполнении макроса на листе дсп строки не появляются. В столбце Н выбивает значения "23" и "23"
Модернизировал таблицу может есть проще вариант. там описан алгоритм
пс. спасибо

[gling]

ДЛЯ ОДНОГО ИЗ СТОЛБЦОВ
=ЕСЛИОШИБКА(ИНДЕКС(A4:AD4;ПОИСКПОЗ( "ДСП*";Z4:Z4;0);29);"")

[gling]

ПОХОЖЕ ЗАДАЧУ ПОНЯЛ НЕПРАВИЛЬНО. ЕСЛИ ФОРМУЛАМИ РЕШАТЬ НАДО ВСЕ СТОЛБЦЫ СЦЕПИТЬ. ЕСЛИ ЕСТЬ НЕОБХОДИМОСТЬ МОЖНО СДЕЛАТЬ.

[Watcher_1]

Лучше тут использовать SQL
Костяк кода взял тут http://www.programmersforum.ru/showt...l+strSql%24%29
Для работы нужен лист с названием shSQL

Sub m()
    myR = Sheets("2").UsedRange.Rows.Count
    Ssql = "SELECT F23, F26, F29, F24, F25, F19, F20, COUNT(F23)  FROM [2$A2:AD" & myR & "] T WHERE F26 LIKE 'ДСП16' GROUP BY F23, F26, F29, F24, F25, F19, F20"
    Debug.Print Ssql
    ADO_R_Dmitry (Ssql)
End Sub

Public Function ADO_R_Dmitry(ByVal strSql$)
    ' P_adm
    shSQL.Columns("A:Q").ClearContents
    FilePath$ = ThisWorkbook.FullName
    Dim sCon As String, FieldName As String
    Dim rs As Object, cn  As Object
    Set rs = CreateObject("ADODB.Recordset")
    Set cn = CreateObject("ADODB.Connection")
    Select Case CLng(Split(Application.Version, ".")(0))
        Case Is < 12
            sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FilePath _
              & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
        Case Is >= 12
            sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FilePath _
            & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
    End Select
    cn.Open sCon
    If Not cn.State = 1 Then Exit Function
    'On Error Resume Next
    'Debug.Print strSql
    Set rs = cn.Execute(strSql)
    
    If Err.Number <> 0 Then Exit Function
    
    
    shSQL.Range("A1").CopyFromRecordset rs
    
    rs.Close:  cn.Close
    Set cn = Nothing: Set rs = Nothing
End Function