VBA

blackeangel · Отправлено: **12:46, 01-12-2017** | #11

Если интересно, вот пример того что надо получить с исходными данными как раз те 6 номеров которые отработали за 10 сек.

blackeangel · Отправлено: **18:06, 01-12-2017** | #12

Iska, есть вот такой код, по словам автора он, в какой то степени решает мою задачу. Но объяснять код отказался. Может вы что скажете дельного?

Код:

Option Explicit
'
'Код для Лист1
'
Dim cl As New Collection
 
Private Sub CommandButton2_Click()
    '
    'Поиск приближенных совпадений
    '
    Dim i&, j&, ii&, jj&, s$, try&, v, CurR&, CurC&
    Dim yes&
    On Error Resume Next 'Включаем игнор ошибок
    Set cl = New Collection 'Инициализируем коллекцию
    CurR = 14 'Сюда будем писать результаты начиная с 14-й строки
    
    With Sheets("лист3") 'Заполняем коллекцию для искомых данных
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear: cl.Add .Cells(i, j), s
                If Err = 0 Then Exit For 'Выход если ключ не занят
            Next
        Next j, i
    End With
    
    With Sheets("лист2")
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            yes = 0
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear
                v = cl(s)
                If Err Then Exit For 'Эта ошибка возникает если совпадений более нет
                yes = 1
                With Sheets("лист1")
                    CurC = (try - 3) * 3
                    .Cells(CurR, 1 + CurC).Value = s
                    .Cells(CurR, 2 + CurC).Value = v
                End With
            Next
            CurR = CurR + yes
        Next j, i
    End With
    
 
End Sub
 
Sub RWord(Range As Range)
    '
    'Случайное слово с точкой и цифрой
    '
    Dim i&, j&, s$
    s = Space(20)
    For i = 1 To 3
        Mid$(s, i, 1) = Chr(97 + Fix(Rnd * 26))
    Next: Mid$(s, i, 1) = "."
    For i = i + 1 To i + 3 + Fix(Rnd * 3)
        Mid$(s, i, 1) = Fix(Rnd * 10)
    Next
    Range.Value = RTrim$(s)
End Sub
 
Private Sub CommandButton1_Click()
    '
    'Создание двух таблиц со случайными значениями
    '
    Dim i&, j&
    With Sheets("лист2")
        .Cells.ClearContents
        For i = 1 To 100: For j = 1 To 10
            RWord .Cells(i, j)
        Next j, i
    End With
    With Sheets("лист3")
        .Cells.ClearContents
        For i = 1 To 200: For j = 1 To 20
            RWord .Cells(i, j)
        Next j, i
    End With
End Sub
 
 
Private Sub CommandButton3_Click()
    With Sheets("лист1")
        .Rows("14:" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    End With
End Sub

blackeangel · Отправлено: **18:07, 01-12-2017** | #13

Вот он же, только в книге.

Iska · Отправлено: **18:26, 01-12-2017** | #14

Цитата blackeangel:

Iska, есть вот такой код, по словам автора он, в какой то степени решает мою задачу. Но объяснять код отказался. Может вы что скажете дельного? »

Ничего не скажу. Ибо не могу по Вашему коду понять Ваш алгоритм и исходную задачу. Равно и то, как приведённый теперь код соответствует Вашему алгоритму. Если автор так утверждает, что ж — берите, пробуйте.

blackeangel · Отправлено: **18:38, 01-12-2017** | #15

Цитата Iska:

Если автор так утверждает, что ж — берите, пробуйте. »

Если б он подходил, я бы взял. Но его надо допил ватт очень долго и усердно. А тк я в коллекциях не в зуб ногой, а вы соображаете.
А свой код методом переборов массива могу расписать от и до, чтоб вам понятно было.

Iska · Отправлено: **18:52, 01-12-2017** | #16

Цитата blackeangel:

А тк я в коллекциях не в зуб ногой, а вы соображаете. »

В данном случае Collection из VBA немного отличается от Dictionary из VBScript в сторону упрощения, но каких-то сложностей там нет: откройте редактор VBA, нажмите F2, наберите в поиске «Collection», нажмите «Enter», выберете класс Collection из библиотеки VBA, в правом окне увидите Members of 'Collection' — все члены класса, выделив конкретный член класса — внизу увидите его описание.

Цитата blackeangel:

А свой код методом переборов массива могу расписать от и до, чтоб вам понятно было. »

Навряд ли выйдет, думаю. Мы ж уже несколько раз пробовали, но не срасталось.

blackeangel · Отправлено: **19:36, 01-12-2017** | #17

Iska,

Цитата Iska:

исходную задачу. »

Заключается в том, что: есть список, есть база. Надо узнать есть ли записи из списка в базе.

А теперь как работает мой код.
Загружаем в 2 массива(arr1 из базы, arr2 c листа).
Берём arr1 и проверяем каждый номер по тому по arr2. Причем проверяем входимость.
Если есть в элементе arr1 "СБ" тогда проверяем, есть ли в текущем элементе arr2 символ "-", Если есть, то в переменную m записываем все что до черточки., проверяем есть ли текущее arr1 + "СБ", дальше сверяем 2 столбца в arr1, и если они равны, то тогда в arr2 пишем значение arr1, если нет, то пишем что "нет страниц" вот этот кусок кода

Код:

For i = LBound(arr1) To UBound(arr1)
        For j = LBound(arr2) To UBound(arr2)
            If Len(arr2(j, 1)) > 0 Then
                If InStr(1, arr1(i, 0), "СБ") > 0 Then
                    If InStr(arr2(j, 1), "-") > 0 Then
                        m = Left(arr2(j, 1), InStr(1, arr2(j, 1), "-") - 1) + "СБ"
                        If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        Else

Едем дальше.
Проверяем есть ли m в текущем arr1, если есть, то сравниваем значения 2х столбцов из arr1, если нет, то пишем в arr2 "нет страниц".

Код:

If InStr(1, m, arr1(i, 0), vbTextCompare) > 0 Then
                                If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                    arr2(j, 2) = arr1(i, 0)
                                Else
                                    arr2(j, 2) = "нет страниц"
                                End If
                            End If
                        End If

Если нет черточки, то тогда к arr2 приляпываем "СБ" и и опять сравниваем столбцы.

Код:

If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        End If
                    End If

Если в arr1 не содержится "СБ", тогда берём и крутим 3й массив в котором есть отметка о типе данной и проверяем есть ли совпадения

Код:

If arr2(j, 2) = Empty Then
                        If InStr(1, arr2(j, 1), arr1(i, 0), vbTextCompare) > 0 Then
                            For k = 1 To UBound(massoboz)
                                If InStr(arr2(j, 1), massoboz(k, 1)) > 0 Then
                                    arr2(j, 2) = "нет сборочного"
                                    Exit For
                                Else
                                    If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                        arr2(j, 2) = arr1(i, 0)
                                    Else
                                        arr2(j, 2) = "нет страниц"
                                    End If
                                End If
                            Next k
                        End If
                    End If

Iska · Отправлено: **19:50, 01-12-2017** | #18

Цитата blackeangel:

Заключается в том, что: есть список, есть база. Надо узнать есть ли записи из списка в базе. »

Тогда бы было всё очень просто сделать одним запросом. Но у Вас-то не так.

Всё, что Вы описываете, понятно из самого кода. Я не об этом. Я о том, что на всё описанное куча вопросов «Зачем?», «Зачем так?» и «Почему именно так, а не иначе?». Понимаете — о чём я?

На всякий случай: в VB/VBA/VBScript есть одна такая хорошая функция Filter. Не знаю, поможет ли она Вам как-то, но посмотрите на примеры её использования.

y-- · Конфигурация компьютера

blackeangel,
Подробнее - либо через DTS либо напрямую через источник данных в ODBC - разово или на постоянной основе организовать перекачку данных в таблицу SQL.
Именно в таблицу - так как дергать по одной записи тож на тож выйдет - то есть медленно.
В процессе переброски не забыть об обрезании пробелов справа и слева для текстовых значений(alltrim()) и приведении всех остальных данных к правильному типу(с полями типа дата может изрядный геморой быть - в общей ситуации може даже проще затягивать как текст и считывать по формату).
А дальше элементарный селект...
Если на постоянной основе делать то надо вначале создать таблицу нужной структуры и единовременно залить все данные, на дальнейшее лучше реализовать что-то типа триггера на доливку/обновление/удаление разности - я-ля реплицировать.
Примеров в сети по работе с DTS - море, да и маны достаточно подробные

Iska · Отправлено: **20:23, 01-12-2017** | #20

y--, SELECT можно и для Рабочего листа Excel выполнять, не в том дело.