Из вертикальной выборки уникальных, в горизонтальную.

[masterenergy]

Здравствуйте уважаемые форумчане. Возник вопрос: Как переделать этот макрос чтобы, он выбирал уникальные значения не из столбцов (вертикально), а из строк. Заранее благодарствую.
Option Explicit

Sub unq()
Dim arr, arr1
Dim Uniq1 As New Collection
Dim lr As Long, lc As Integer, c As Integer, i As Integer
Application.ScreenUpdating = False

arr = ActiveSheet.UsedRange
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count


For c = 1 To lc
For i = 1 To UBound(arr)
On Error Resume Next
Uniq1.Add arr(i, c), arr(i, c)
Next

ReDim arr1(1 To Uniq1.Count, 1 To 1)
For i = 1 To Uniq1.Count
arr1(i, 1) = Uniq1(i)
Next

Range(Cells(lr + 1, c), Cells(lr + UBound(arr1), c)).Value = arr1
Set Uniq1 = Nothing

Next

Application.ScreenUpdating = True
End Sub

Пытался переделать:

lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count

в

lr = Cells(Columns.Count, 1).End(xlRight).Column
lc = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count


Не помогло.

[nilem]

Так попробуйте (если ничего особо не менять):

Sub unq2()
Dim arr, arr1()
Dim Uniq1 As New Collection
Dim lr As Long, lc As Integer, c As Integer, i As Integer
Application.ScreenUpdating = False

arr = ActiveSheet.UsedRange
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count

On Error Resume Next
For c = 1 To lr

    For i = 1 To UBound(arr, 2)
        Uniq1.Add arr(c, i), CStr(arr(c, i))
    Next

    ReDim arr1(1 To Uniq1.Count)
    For i = 1 To Uniq1.Count
        arr1(i) = Uniq1(i)
    Next

    Range(Cells(c, lc + 1), Cells(c, lc + UBound(arr1))).Value = arr1
    Set Uniq1 = Nothing

Next

Application.ScreenUpdating = True
End Sub

PS Похоже на раннего Hugo (могу ошибаться)

[masterenergy]

Скорее всего не ошибаетесь потому как этот код вроде он мне и подсказал (могу тоже конечно ошибаться). Хотя может вы и не о том.
Спасибо за помощь.

[Hugo121]

Не, это не я
lr, lc - это не моё.
И я обычно Integer не использую. Кстати, здесь на этом прокол:

lr As Long, c As Integer, i As Integer
...
lr = Cells(Rows.Count, 1).End(xlUp).Row
...
For c = 1 To lr
...
For i = 1 To Uniq1.Count

Но ошибки не будет, ведь:
On Error Resume Next



P.S. Хотя Uniq1 вроде никогда до предела Integer в варианте Николая не дойдёт... ну ладно, один прокол возможен.
А в верхнем коде два, а может и больше.

[IgorGO]

сообщение к теме не имеет отношения, извините.

Похоже на раннего Hugo

замечательно))) вспомнилось из раннего Шекспира:
2B OR NOT 2B = FF

[Hugo121]

Это наверное не обо мне, я меньше года на этом форуме... Цифры в ник пришлось добавить потому, что есть/был? другой Hugo
P.S. уже нет, я один остался...