Макрос: открыть книгу, перейти на лист, найти строку и скопировать

[staniiislav]

вот еще немного переделал, добавил функцию EducatedFool

[Hugo121]

А если книг будет сотня? Памяти сразу на все хватит?
MaxxVer - сколько там их может быть всего?
И я бы уж в любом случае не стал их активировать (кстати, код и без активации работает вроде правильно )

P.S. А словарь там зачем?

[MaxxVer]

Книг порядка 30.

[staniiislav]

Сообщение от Hugo121

А если книг будет сотня? Памяти сразу на все хватит?

тогда или впр или запрос sql как Вы уже выкладывали

Сообщение от Hugo121

И я бы уж в любом случае не стал их активировать (кстати, код и без активации работает вроде правильно )

))) активацией я проверяю есть ли книга или лист, если нет то соответствующее сообщение в ячейку

Сообщение от Hugo121

P.S. А словарь там зачем?

со словарем запарился ))) надо убрать, хоте с начало через len перебегать книги, а потом забыл убрать

[Hugo121]

С SQL никто пока варианта не предложил, только упоминали - но я например не знаю, как можно сделать на SQL без лишнего открытия книг.
Потихоньку думаю, как бы на словарях сделать красиво - но красиво не придумывается

30 книг вероятно потянет.


А с проверкой наличия книги можно иначе сделать, и без активации - но я бы вероятно и тут использовал вместо кода тёзки свой обычный словарь
Т.е. собираем в словарь имена открываемых книг, затем перебором словаря их открываем и сразу смотрим - есть ли ошибка. И сразу в словаре отмечаем - вот эта не открылась.
Затем в коде проверяем уже по словарю - всё ли прошло хорошо.
Конечно, есть риск, что книга вылетит в процессе работы - но она и так может вылететь в любой момент, если система/комп кривые...

[staniiislav]

если будет время на выходных, может что-нить про sql почитаю... глядишь, прозрение придет )))

[Hugo121]

Сделал то, что было интересно - как файлы открывать только один раз.
Код делал на файле Станислава 2.rar (38.6 Кб) - он выше на этой странице.

Option Explicit

Sub tt()
    Dim a(), i&, oD_B As Object, oD_BS As Object, wb As Object
    Dim t$, elB, elS, elK, krit$, poz&, calc_status&

    Dim временнаястрока$

    Set oD_B = CreateObject("Scripting.Dictionary")    'книги с листами
    Set oD_BS = CreateObject("Scripting.Dictionary")    'книги|листы с критериями и позициями

    a = [a3].CurrentRegion.Value 'это можно/нужно сделать иначе, не важно как
    ReDim b(1 To UBound(a), 1 To 6) 'массив результатов

    '==== заполняем словари
    For i = 1 To UBound(a)
        t = a(i, 1) & "|" & a(i, 2)    'чтоб сто раз не лазить/делать :)

        If Not oD_B.exists(a(i, 1)) Then    'если книги нет
            oD_B.Item(a(i, 1)) = a(i, 2)    'в книгу лист
            oD_BS.Item(t) = a(i, 3) & "@@" & i    'в кн|лист критерий и позицию
        Else    'если книга есть
            If Not oD_BS.exists(t) Then    'если кн|листа нет
                oD_B.Item(a(i, 1)) = oD_B.Item(a(i, 1)) & "|" & a(i, 2)    'пополняем в книге лист
                oD_BS.Item(t) = a(i, 3) & "@@" & i    'в кн|лист критерий и позицию
            Else
                oD_BS.Item(t) = oD_BS.Item(t) & "|" & a(i, 3) & "@@" & i
            End If
        End If
    Next

    '===== открываем книги, ищем по листам данные
    With Application
        calc_status = .Calculation
        .Calculation = xlManual
        .ScreenUpdating = False
        .EnableEvents = False

        On Error Resume Next
        For Each elB In oD_B    'книги
            Debug.Print "Открываем " & elB
            Set wb = GetObject(ThisWorkbook.Path & "\" & elB & ".xls")
            If Err = 0 Then
                For Each elS In Split(oD_B.Item(elB), "|") 'листы
                    t = oD_BS.Item(elB & "|" & elS)
                    For Each elK In Split(t, "|")
                        krit = Split(elK, "@@")(0)
                        poz = Split(elK, "@@")(1)
                        временнаястрока = "В wb на листе " & elS & " ищем " & krit & ", пишем в " & poz & " строку"
                        Debug.Print временнаястрока
                        'тут собственно всё и происходит :)
                        'можно взять готовый код от staniiislav :)
                        'дополнительно обработать отсутсвие листа
                        'но пишем в объявленный массив
                        b(poz, 1) = временнаястрока
                        'который в финале выгружаем
                    Next
                Next
                Debug.Print "Закрываем " & elB
                wb.Close 0
            Else
                Err.Clear
                For Each elS In Split(oD_B.Item(elB), "|")
                    t = oD_BS.Item(elB & "|" & elS)
                    For Each elK In Split(t, "|")
                        'krit = Split(elK, "@@")(0)'это сейчас не нужно
                        poz = Split(elK, "@@")(1)
                        временнаястрока = "Книга " & elB & " не найдены!"
                        Debug.Print временнаястрока
                        'пишем ошибку
                        b(poz, 1) = временнаястрока
                    Next
                Next
            End If
        Next
        
        On Error GoTo 0
        
        Sheets(1).[d3].Resize(UBound(b, 1), UBound(b, 2)) = b

        .Calculation = calc_status
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Книги, листы и даже критерии могут повторяться (по логике комбинация книга/лист/критерий повторяться не должна, но всяко бывает - учёл).
Т.е. в одном конкретном листе можно искать не одного "человека", а сколько угодно (сколько в string поместится).
Позиция вывода естественно повторится физически не может.

[doober]

Сообщение от Hugo121

С SQL никто пока варианта не предложил, только упоминали - но я например не знаю, как можно сделать на SQL без лишнего открытия книг.
..

Если предложеный Игорем вариант не подойде,можно и SQL попробовать,но по скорости он проиграет словарю,я так думаю.
Я бы сделал так.
Отобрал книга-лист пары.
Далее запросом получил нужные данные и записал бы скорее всего в файл Access ,на крайний случай в CSV в таком формате.
Книга,лист, подопытный и остальные данные.
Если в Access ,то создать таблицу соответствий и вывести результат,но мороки много.Если файлы большие ,под 10-20 тыс строк,то есть смысл поиграться с этим вариантом

[staniiislav]

Сообщение от Hugo121

Сделал то, что было интересно - как файлы открывать только один раз.

очень хорошее решение! думал как на sql это сделать, в принципе можно, но по скорости будет проигрывать, т.к. книг на открытие много...

[Hugo121]

На словаре с коллекцией вроде попроще получается.
Схематично так:

Sub PereborFailov()
    Dim a, i&, t$, Dic As Object
    Dim el, col
    
    a = Range("C3", Cells(Rows.Count, "A").End(xlUp)).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = a(i, 1)
            If Not .Exists(t) Then .Add t, New Collection
            .Item(t).Add a(i, 2) & "|" & a(i, 3) & "|" & i
        Next
    End With
    
    For Each el In Dic.keys
        Debug.Print "Открываем файл " & el
        For Each col In Dic.Item(el)
            Debug.Print "Ищем данные " & col
        Next
        Debug.Print "Закрываем файл " & el
    Next

End Sub

Или словарь в словаре:

Sub PereborFailov2() ' словарь в словаре
    Dim a, i&, t$, Dic As Object, Dic2 As Object
    Dim el, col
    
    a = Range("C3", Cells(Rows.Count, "A").End(xlUp)).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = a(i, 1)
            If Not .exists(t) Then .Add t, CreateObject("Scripting.Dictionary")
            .Item(t).Item(a(i, 2) & "|" & a(i, 3) & "|" & i) = 0&
            
        Next
    End With
    
    For Each el In Dic.keys
        Debug.Print "Открываем файл " & el
        Set Dic2 = Dic.Item(el)
        For Each col In Dic2.keys
            Debug.Print "Ищем данные " & col '& "|" & Dic2.Item(col)
        Next
        Debug.Print "Закрываем файл " & el
    Next

End Sub