Добрый вечер. 1.На первом листе исходные данные, с меткой "Уникальное". Беру диапазон от "Уникального" до ближайщего "Уникального". 2.Выделяю уникальные и сортирую по алфавиту. 3. А вот закинуть tbl в Redim что-то не получается.
Ребята, подскажите пожалуйста, где я ошибаюсь при выводе массива на лист "готово".
Макрос тут
Код
Sub ArrUniqSort()
Dim Uniq As New Collection, i&, ii&, iii&, iiii&, y&, n&, s, b As Range, a&
Dim x, tbl, arr, lstr&, c&
Application.ScreenUpdating = False
lstr = Cells(Rows.Count, 1).End(xlUp).Row
c = Application.WorksheetFunction.CountIf(Range("F1:F" & lstr), "Уникальное")
With Worksheets(1).Range("F1:F" & lstr)
Set b = .Find("Уникальное", , xlValues, xlPart)
If Not b Is Nothing Then
For i = 1 To c
a = b.Row
Set b = .FindNext(b)
If i = c Then
Set arr = Range("A" & a & ":F" & lstr)
Else
Set arr = Range("A" & a & ":F" & b.Row - 1)
End If
For n = 1 To 5 ' дапазон столбцов, где ищем уникальные
For ii = 1 To arr.Rows.Count ' дапазон строк, где ищем уникальные
On Error Resume Next
Uniq.Add arr(ii, n), CStr(arr(ii, n)) ' создаём item уникальных
Next
Next
ReDim arr(1 To Uniq.Count)
For iii = 1 To Uniq.Count
arr(iii) = Uniq(iii) 'из item переводим уникальные в value
Next
On Error Resume Next
With New Collection 'создание коллекции для сортировки value
For Each x In arr
If Len(x) > 0 Then 'пустые значения игнорируем
If IsEmpty(.Item(x)) Then 'пустые значения игнорируем
For iiii = 1 To .Count
If x < .Item(iiii) Then Exit For
Next
If iiii > .Count Then
.Add x, x
Else
.Add x, x, Before:=iiii 'сортировка по алфавиту
End If
End If
End If
Next
ReDim tbl(1 To 1, 1 To .Count)
For iiii = 1 To .Count
tbl(i, iiii) = .Item(iiii)
Next
Sheets("готово").Range("A" & i).Resize(1, .Count).Value = tbl
End With
Next
End If
End With
Application.ScreenUpdating = True
End Sub
Владимир, я правильно понимаю, что у Вас в итоге должен получиться ОДИН столбец из значений строк, помеченных как 'Уникальные', отсортированный по ...как отсортированный? Можете в файле желаемый результат руками накидать
Согласие есть продукт при полном непротивлении сторон
У меня должно получится 6 строк, т.к. меток всего 6. А столбцы по-разному в динамике должны загрузиться, согласно количеству уникальных в диапазоне от Уникального до Уникального. ---------- Сейчас накидаю..
ReDim tbl(1 To 1, 1 To .Count)
For iiii = 1 To .Count
tbl(i, iiii) = .Item(iiii)
тут косяк в третьей строке. если i > 1, будет ошибка, так как для tbl первое измерение определено 1 To 1. то есть, по идее, должно быть не tbl(i, iiii) а tbl(1, iiii)
дальше логику выгрузки не смотрел детально, но вроде всё должно быть ок
У меня Uniq не очищается после первого цикла. Пытаюсь Uniq.RemoveAll, но что-то не так... Всё равно какой-то нарастающий итог получается. -------- Да, Максим, это косяк. Спасибо за подсказку.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Владимир, посмотрите мой вариант. Массив массивов (вдруг кто-то будет искать по такому словосочетанию)
Скрытый текст
Код
Option Explicit
Sub ArrUniqSort()
Dim i&, j&, n&, k&, ii&
Dim arr()
Dim arrTbl()
'забираем все данные с листа в массив
With Worksheets(1)
arr = .Range("A1:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
On Error Resume Next
n = 1
For i = 1 To UBound(arr, 1)
If arr(i, 6) = "Уникальное" Then
With New Collection 'проверка на уникальность и сортировка
For j = 1 To UBound(arr, 2) - 1
If arr(i, j) <> Empty Then
.Add arr(i, j), CStr(arr(i, j))
If Err = 0 Then
If n > 1 Then
If .Item(n - 1) > arr(i, j) Then
.Remove (CStr(arr(i, j)))
.Add arr(i, j), CStr(arr(i, j)), .Item(n)
End If
End If
n = n + 1
Else
Err.Clear
End If
End If
Next
n = 1
'создаем массив МАССИВОВ с уникальными сортированными
ReDim Preserve arrTbl(k)
ReDim tbl(.Count - 1)
For ii = 1 To .Count
tbl(ii - 1) = .Item(ii)
Next
arrTbl(k) = tbl
k = k + 1
End With
End If
Next
'переносим массив массивов в простой двумерный массив
n = Empty
ReDim arrUnSt(UBound(arrTbl), 0)
For i = 0 To UBound(arrTbl)
For j = 0 To UBound(arrTbl(i))
If UBound(arrTbl(i)) > UBound(arrUnSt, 2) Then ReDim Preserve arrUnSt(UBound(arrTbl), UBound(arrTbl(i)))
arrUnSt(i, n) = arrTbl(i)(j)
n = n + 1
Next
n = Empty
Next
'выгружаем массив на лист
With Worksheets("готово")
.Range("G1:Q" & .Cells(.Rows.Count, "G").End(xlUp).Row).ClearContents
.Range("G1").Resize(UBound(arrUnSt, 1) + 1, UBound(arrUnSt, 2) + 1) = arrUnSt
End With
Application.ScreenUpdating = True
End Sub