Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Перебор всех значений из ячеек и выворка уникальных
 
#1
27.12.2019 21:06:59
Привет. Встала не простая задачка, с помощью формул я не смог решить .
Есть данные - они заполняются в столбце "А", их может быть до 150 тысяч строк.
Нужно пройтись по каждой ячейки столбца "А" и выверить уникальные символы и буквы.

Пример и результат в нем .
Спасибо.
(Нужно для создания игры собрать слова из букв)
Спасибо.
Изменено: Malkov111123 - 27.12.2019 21:33:38
 
 
 
#2
27.12.2019 21:19:53
в сообщении ни примера ни результата

вспомнилось, как Кай задумчиво передвигая буквы по льду в порыве отчаяния сказал Снежной королеве:
- Королева, я не могу из букв А Ж О и П собрать слово ВЕЧНОСТЬ!
P/S. вы аккуратно там с буквами, чтобы не краснеть за слова, собранные детьми)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
27.12.2019 21:24:23
Ігор Гончаренко, не подкрепился с первого раза почему то  
 
 
 
#4
27.12.2019 21:30:35
Цитата
Malkov111123 написал:
до 150 тысяч строк
Что-то я не представляю, как при таком количестве исходных данных можно не использовать какой-либо символ или букву, т.е. результат изначально - все возможные буквы и символы...
 
 
 
#5
27.12.2019 21:32:41
Alec Perle,
Там заморочка больше с символами.  
 
 
 
#6
27.12.2019 22:06:40
Доброе время суток
Вариант
Код
Public Sub ShowUniqueChars()
    Const LastChar As Long = 65536
    Dim LRow As Long, vData As Variant
    Dim LChars(0 To LastChar) As Long
    Dim FoundChars() As String, t As Single
    t = Timer
    Dim FoundId As Long, Bytes() As Byte
    Dim i As Long, k As Long, CurChar As Long
    ReDim FoundChars(0 To LastChar)
    LRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    vData = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(LRow, 1)).Value
    For i = 1 To UBound(vData)
        Bytes = LCase$(vData(i, 1))
        For k = LBound(Bytes) To UBound(Bytes) Step 2
            CurChar = 256& * Bytes(k + 1) + Bytes(k)
            LChars(CurChar) = 1
        Next
    Next
    FoundId = -1
    For i = LBound(LChars) To UBound(LChars)
        If LChars(i) = 1 Then
            FoundId = FoundId + 1
            FoundChars(FoundId) = ChrW(i)
        End If
    Next
    ReDim Preserve FoundChars(0 To FoundId)
    MsgBox """" & Join$(FoundChars, """;""") & """" & vbLf & CStr(Timer - t)
End Sub

Для фразы - Королева, я не могу из букв А Ж О и П собрать слово ВЕЧНОСТЬ!With Safari, you learn the way you learn best. Get unlimited access to videos, live online training, learning paths, books, interactive tutorials, and more., размноженной на 150000 ячеек, выполнение составило полторы секунды.
 
 
 
#7
27.12.2019 22:14:50
Андрей VG,
Отлично, а что бы скопировать результат ?)
 
 
 
#8
28.12.2019 19:35:05
Цитата
Malkov111123 написал:
а что бы скопировать результат ?)
Преобразовать, например, в UDF-функцию
Код
Public Function GetUniqueChars(ByVal FromColumn As Range) As String
    Const LastChar As Long = 65536
    Dim LRow As Long, vData As Variant
    Dim LChars(0 To LastChar) As Long
    Dim FoundChars() As String
    Dim FoundId As Long, Bytes() As Byte
    Dim i As Long, k As Long, CurChar As Long
    ReDim FoundChars(0 To LastChar)
    vData = FromColumn.Value
    For i = 1 To UBound(vData)
        Bytes = LCase$(vData(i, 1))
        For k = LBound(Bytes) To UBound(Bytes) Step 2
            CurChar = 256& * Bytes(k + 1) + Bytes(k)
            LChars(CurChar) = 1
        Next
    Next
    FoundId = -1
    For i = LBound(LChars) To UBound(LChars)
        If LChars(i) = 1 Then
            FoundId = FoundId + 1
            FoundChars(FoundId) = ChrW(i)
        End If
    Next
    ReDim Preserve FoundChars(0 To FoundId)
    GetUniqueChars = """" & Join$(FoundChars, """;""") & """"
End Function
 
 
 
#9
29.12.2019 18:28:49
Андрей VG,Спасибо
 
 
 
Страницы: 1
Наверх