Поиск уникальных значений (для заключения)

Опубликовано автор kos20 
Option Explicit
Public LastRow As Integer
 
 
Sub HelloWorld(control As IRibbonControl)
On Error Resume Next
Application.ScreenUpdating = False
    Trim
Application.ScreenUpdating = True
End Sub
 
 
 
Private Sub Trim()
    Dim ws6 As Worksheet
    Dim ws14 As Worksheet
    Set ws6 = ThisWorkbook.Sheets("6-КредМод")
    Set ws14 = ThisWorkbook.Sheets("14-Аудит Обеспеч")
Application.ScreenUpdating = False
 
ChangeCellRef
 
    With ws14.Range("1:1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
 
 If Sh_Exist("14-Аудит Обеспеч") Then
    ws14.Select
    ws14.Range("1:1").Font.Bold = True
    ws14.Range(Cells(1, 1), Cells(Cells.SpecialCells(xlLastCell).Row, Cells.SpecialCells(xlLastCell).Column)).Select
    TRIMinSelection
    Range("A1").Select
    Range("H:K").NumberFormat = "#,##0_ ;[Red]-#,##0 "
    Range("M:N").NumberFormat = "#,##0_ ;[Red]-#,##0 "
 Else
    MsgBox "Лист 14-Аудит Обеспеч не найден!", vbOKOnly
 End If
 
 Trim2
 
Application.ScreenUpdating = True
End Sub
 
Private Sub TRIMinSelection()
    Dim rngRectangle As Range, rngRows As Range, rngColumns As Range
    Set rngRectangle = Selection
    Set rngRows = rngRectangle.Resize(, 1)
    Set rngColumns = rngRectangle.Resize(1)
    rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "), IF(COLUMN(" & rngColumns.Address & "),TRIM(" & rngRectangle.Address & ")))")
End Sub
 
Private Function Sh_Exist(Sname As String) As Boolean
    Dim wsSh As Worksheet
    On Error Resume Next
    Set wsSh = ThisWorkbook.Sheets(Sname)
    Sh_Exist = Not wsSh Is Nothing
End Function
 
 
Private Sub Trim2()
 
 If Sh_Exist("6-КредМод") And _
    Sh_Exist("14-Аудит Обеспеч") And _
    Sh_Exist("14-1-Обеспеч Зал") And _
    Sh_Exist("14-2-Обеспеч Пор") Then
 
 
    ThisWorkbook.Sheets("6-КредМод").Select
    Range("K1:K" & 100).Select
    TRIMinSelection
 
    Dim i As Integer
    Dim Row As Integer
'    Dim LastRow As Integer
    Dim LastRow14 As Integer
    Dim val6 As Variant
 
    Dim Count141 As Integer
    Dim Count142 As Integer
 
    Dim ws6 As Worksheet
    Dim ws14 As Worksheet
    Dim ws141 As Worksheet
    Dim ws142 As Worksheet
 
    Set ws6 = ThisWorkbook.Sheets("6-КредМод")
    Set ws14 = ThisWorkbook.Sheets("14-Аудит Обеспеч")
    Set ws141 = ThisWorkbook.Sheets("14-1-Обеспеч Зал")
    Set ws142 = ThisWorkbook.Sheets("14-2-Обеспеч Пор")
 
    ws141.Range("2:" & ws141.Cells.SpecialCells(xlLastCell).Row).ClearContents
'    ws142.Range("2:" & ws142.Cells.SpecialCells(xlLastCell).Row).ClearContents
 
    LastRow = ws6.Cells.SpecialCells(xlLastCell).Row
    For i = 2 To 100
         If Len(ws6.Range("K" & i).Value) = 0 Then
            LastRow = i - 1 'нашли последню запись
            Exit For
         End If
    Next i
'Перенос данных на листы
Count141 = 1
Count142 = 1
    For i = 2 To LastRow
        val6 = ws6.Range("K" & i).Value
        LastRow14 = ws14.Cells.SpecialCells(xlLastCell).Row
 
        For Row = 2 To LastRow14
            If val6 = ws14.Range("R" & Row).Value Then
               If ws14.Range("C" & Row).Value <> "ГарантИДо" Then
                  Count141 = Count141 + 1
 
                  ws141.Range("A" & Count141) = ws14.Range("R" & Row).Value
                  ws141.Range("B" & Count141) = ws14.Range("A" & Row).Value
                  ws141.Range("C" & Count141) = ws14.Range("B" & Row).Value
                  ws141.Range("D" & Count141) = ws14.Range("C" & Row).Value
                  ws141.Range("E" & Count141) = ws14.Range("D" & Row).Value
                  ws141.Range("F" & Count141) = ws14.Range("G" & Row).Value
                  ws141.Range("G" & Count141) = ws14.Range("I" & Row).Value
                  ws141.Range("H" & Count141) = ws14.Range("J" & Row).Value
                  ws141.Range("I" & Count141) = ws14.Range("K" & Row).Value
                  ws141.Range("J" & Count141) = ws14.Range("M" & Row).Value
                  ws141.Range("K" & Count141) = ws14.Range("N" & Row).Value
                  ws141.Range("L" & Count141) = ws14.Range("O" & Row).Value
 
               Else
                  Count142 = Count142 + 1
 
                  ws142.Range("A" & Count142) = ws14.Range("R" & Row).Value
                  ws142.Range("B" & Count142) = ws14.Range("A" & Row).Value
                  ws142.Range("C" & Count142) = ws14.Range("B" & Row).Value
                  ws142.Range("D" & Count142) = ws14.Range("C" & Row).Value
                  ws142.Range("E" & Count142) = ws14.Range("D" & Row).Value
                  ws142.Range("F" & Count142) = ws14.Range("G" & Row).Value
                  ws142.Range("G" & Count142) = ws14.Range("I" & Row).Value
                  ws142.Range("H" & Count142) = ws14.Range("J" & Row).Value
                  ws142.Range("I" & Count142) = ws14.Range("K" & Row).Value
                  ws142.Range("J" & Count142) = ws14.Range("M" & Row).Value
                  ws142.Range("K" & Count142) = ws14.Range("N" & Row).Value
                  ws142.Range("L" & Count142) = ws14.Range("O" & Row).Value
 
               End If
 
            End If
        Next Row
 
'        If ws14.Range("R2:R" & ws14.Cells.SpecialCells(xlLastCell).Row).Find(val6) Is Nothing Then
'           ws141.Range("A" & Count141 & ":L" & Count141) = Array(val6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
'           ws142.Range("A" & Count142 & ":L" & Count142) = Array(val6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
'        End If
    Next i
 
 Else
    MsgBox "Какой-то лист отсутствует!", vbOKOnly
 End If
ws141.Range("G:K").NumberFormat = "#,##0.00;[Red]-#,##0.00"
ws142.Range("G:K").NumberFormat = "#,##0.00;[Red]-#,##0.00"
 
ws6.Range("K2").Select
 
Extract_Unique22 ws141
Extract_Unique22 ws142
 
ThisWorkbook.Sheets("14-Аудит Обеспеч").Select
End Sub
 
 
'Прцедура оставляет только уникальные значения
Sub Extract_Unique22(ws141 As Worksheet)
    Dim vItem, avArr, li As Long
    Dim count As Integer
    count = 1
 
    Dim var As Variant
 
    ReDim avArr(1 To ws141.Rows.count, 1 To 12)
    With New Collection
        On Error Resume Next
        For Each vItem In ws141.Range("C2:C" & Cells.SpecialCells(xlLastCell).Row)
        'Cells(Rows.Count, 1).End(xlUp) - определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1
                avArr(li, 1) = ws141.Range("A" & li + count).Value
                avArr(li, 2) = ws141.Range("B" & li + count).Value
                avArr(li, 3) = vItem
                avArr(li, 4) = ws141.Range("D" & li + count).Value
                avArr(li, 5) = ws141.Range("E" & li + count).Value
                avArr(li, 6) = ws141.Range("F" & li + count).Value
                avArr(li, 7) = ws141.Range("G" & li + count).Value
                avArr(li, 8) = ws141.Range("H" & li + count).Value
                avArr(li, 9) = ws141.Range("I" & li + count).Value
                avArr(li, 10) = ws141.Range("J" & li + count).Value
                avArr(li, 11) = ws141.Range("K" & li + count).Value
                avArr(li, 12) = ws141.Range("L" & li + count).Value
 
            Else
               Err.Clear
               count = count + 1
 
            End If
        Next
    End With
 
    ws141.Range("2:100").ClearContents
    If li Then ws141.[A2:L2].Resize(li).Value = avArr
 
End Sub
 
 
 
Sub ChangeCellRef()
If Application.ReferenceStyle = xlR1C1 Then
    Application.ReferenceStyle = xlA1  'xlR1C1
'Else
'    Application.ReferenceStyle = xlR1C1
End If
End Sub