Добрый день, Друзья
Описание кода:
1) Проверяет есть ли ошибки в диапазоне данных S10:S500 на листе "Лист1"
2) Просматривает диапазон данных S10:S500 на листе "Лист1" и выбирает только уникальные значения, записывает на этот же лист в ячейку начиная с "C10".
3) После проверки данных копирует все данные c листа "Лист1" данные из диапазона I10:R500 и вставляем на лист "Order" в ячейки A2:J2
Подскажите как исправить код, что бы 3-й пункт реализации кода всё таки заработал.
Описание кода:
1) Проверяет есть ли ошибки в диапазоне данных S10:S500 на листе "Лист1"
2) Просматривает диапазон данных S10:S500 на листе "Лист1" и выбирает только уникальные значения, записывает на этот же лист в ячейку начиная с "C10".
3) После проверки данных копирует все данные c листа "Лист1" данные из диапазона I10:R500 и вставляем на лист "Order" в ячейки A2:J2
Подскажите как исправить код, что бы 3-й пункт реализации кода всё таки заработал.
Код |
---|
'-------------------------------------------------------------------------- Sub MassUnique() Dim myArr(), MassUnique() Dim cl As Range Dim ShtR As Worksheet Dim ShtA As Worksheet Dim S As Long Dim B As Long Dim A As Long Dim C As Long Set ShtR = Workbooks("mail.xlsm").Worksheets("Order") ShtR.Range("A2:J500" & WorksheetFunction.Max(4, ShtR.Cells(ShtR.Rows.Count, 1).End(xlUp).Row)).Value = "" S = 1 With Worksheets("Лист1") myArr = .Range("S10:S500" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value For Each cl In .Range("S10:S500" & .Cells(.Rows.Count, 1).End(xlUp).Row) If IsError(cl) Then MsgBox "Текст сообщения""Текст""", vbExclamation + vbOKCancel Exit Sub C = ShtA.Cells(.Rows.Count, 1).End(xlUp).Row If C > 0 Then For A = 1 To C S = S + 1 ShtR.Cells(S, 1).Resize(1, 2).Value = .Range(.Cells(A, 10), .Cells(A, 11)).Value ShtR.Cells(S, 3).Resize(1, 2).Value = .Range(.Cells(A, 12), .Cells(A, 13)).Value ShtR.Cells(S, 5).Resize(1, 2).Value = .Range(.Cells(A, 14), .Cells(A, 15)).Value ShtR.Cells(S, 7).Resize(1, 2).Value = .Range(.Cells(A, 16), .Cells(A, 17)).Value ShtR.Cells(S, 9).Resize(1, 1).Value = .Range(.Cells(A, 18), .Cells(A, 18)).Value Next A End If End If Next '---------------- End With MassUnique = UniqueValuesFromArray(myArr, 1) ActiveSheet.Range("C10").Resize(UBound(MassUnique)) = MassUnique End Sub Sub MassClear() Range("C10:C96").ClearContents End Sub '--------------------------------------------------------------------------------------- Function UniqueValuesFromArray(ByVal Arr, ByVal col As Long) As Variant Dim i As Integer If Not IsArray(Arr) Then MsgBox "Текст сообщения!", vbCritical: Exit Function If col > UBound(Arr, 2) Then MsgBox "Текст сообщения!", vbCritical: Exit Function If col < LBound(Arr, 2) Then MsgBox "Текст сообщения!", vbCritical: Exit Function On Error Resume Next: Dim coll As New Collection, txt$ For i = LBound(Arr) To UBound(Arr) txt$ = Trim(Arr(i, col)): coll.Add txt$, txt$ Next i ReDim newarr(1 To coll.Count, 1 To 1) For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i UniqueValuesFromArray = newarr End Function |