Excel VBA Макросы: Открытие книги, порверка значения листа, копирование значений.

[gtz]

Имеется открытая книга (wb1). необходимо открыть другую книгу (wb2).
В другой книге (wb2) есть листы с информацией разных типов - если инфо на листе в определенной ячейке соотвествует требьованию то данные с листа wb2 копируются в строку в открытой книге, условие в постоянной ячейке (wb2).
Информация с каждого листа wb2 соотвествющая условию (в определенной ячейке оно указано) копируется в отдельную строку wb1.
Ячейки с необходимой информацией распологаются в постоянных местах (ячейках), т.е. копирование прямое кажждой ячейки в ячейки строки.
Например, wb2 имеет 5 листов, на 3-х из них имеется необходимая информация (указывается в ячейке 'b1'), соотвественно на wb1 должно появиться 3 строки со скопированными данными из wb2.
Если в ячейке b1 value дерево, то переносить данные в wb1.
В макросе указывается что необходимы данные с листа на котором указано "деревья".
Далее происходит копирование в строку данных с найденных листов, определенных ячеек wb2 в определенные ячейки wb1.
Данные с каждого соотвествующего листа wb2 копируются в отдельную строку wb1.
Все листы обработаны MsgBox "Данные перенесены" End Sub.
Например,
1 - если макрос определил, что на листе wb2 информация о дереве IF b1="дерево", то запускается процесс копирования в новую строку в wb1 определенных ячеек в данной ситуации:
b2(wb2) = a2(wb1)
b3(wb2) = b2(wb1)
b4(wb2) = c2(wb1)
b5(wb2) = d2(wb1)
b6(wb2) = e2(wb1)
Важно именно привязка постоянных ячеек к постоянным ячейкам, без формул "+1" к следующей ячейке/столбцу
2 - для следующего листа wb2 с соотвествующей информацией заполняется новая строка
3 - если макрос определил, что на листе wb2 информация в ячейке b1 не соответсвует заданному значению, то переход на следующий лист, если листов больше нет, то MsgBox "Данные перенесены" End Sub
Также важно что листы не оязательно называются Лист1, Лист2 и т.д.
Они могут быть переименованы, порядковый номер и Name может также быть утрачен.

В общем пока дошел до простого переноса данных с функцией если
Соответсвенно дело за малым =))
Создание новых строк и переход на следующий лист
Например если на первом листе нет инфо то переход на следующий

Спойлер

Sub OpenAndCopySub()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet

'Отключение монитора
Application.ScreenUpdating = False

Set wb1 = ActiveWorkbook


'открытие книги
  FilesToOpen = Application.GetOpenFilename(, , "Выбери файл")
      If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Ну ёклмн, файл не выбран!"
        Exit Sub
        Else: Set wb2 = Workbooks.Open(Filename:=FilesToOpen)
     
      End If
If wb2.Worksheets(1).Range("b1").Value = "Дерево" Then
        wb1.Worksheets(1).Range("a2").Value = wb2.Worksheets(1).Range("b2").Value
        wb1.Worksheets(1).Range("b2").Value = wb2.Worksheets(1).Range("b3").Value
        wb1.Worksheets(1).Range("c2").Value = wb2.Worksheets(1).Range("b4").Value
        wb1.Worksheets(1).Range("d2").Value = wb2.Worksheets(1).Range("b5").Value
        wb1.Worksheets(1).Range("e2").Value = wb2.Worksheets(1).Range("b6").Value

Else: MsgBox "Не найдено!"
Exit Sub
End If
     
     
 
  'NumberRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row + 1
 
 
  'Если (1) содержимое {ячейки а1 листа 1 открываемой книги (Workbooks.Open)} = "определеное значение"
        'копируем из открываемой книги в открытую, в ту которой выполняется макрос
            ' b1 строки 1(открытой книги) = a10 листа 1 (открываемой книги(Workbooks.Open))
            ' b2 строки 1(открытой книги) = a24 листа 1 (открываемой книги(Workbooks.Open))
            ' b3 строки 1(открытой книги) = a36 листа 1 (открываемой книги(Workbooks.Open))
            '...
            'Далее переход на новую строку для заполнения данных со следующего листа открываемой книги (если они есть)
  'Else переход на следующий лист и повторение процедуры goto Если (1) ?
'Закрытие книги wb2
wb2.Close (False)
  ' Включение монитора.
    Application.ScreenUpdating = True
End Sub

[свернуть]

Wb1 - открытый файл
Wb2 - открываемый файл

[вложение удалено администратором]

[Администратор]

Макрос

Sub OpenAndCopySub()

    Dim sh_res As Worksheet, wb2 As Workbook, sh_src As Worksheet
    Dim FN As String, lr As Long
   
   
    '1. Юзер выбирает файл.
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "OK"
        .Filters.Clear
        .Filters.Add "Файлы Excel", "*.xls*"
        .Title = "Выбери файл"
        If .Show = 0 Then
            Exit Sub
        End If
        FN = .SelectedItems(1)
    End With
   
    ' Отключение монитора для ускорения макроса и чтобы не мерацало.
        ' Лучше делать после выбора файла, иначе если юзер потащит диалог, то он размножится по экрану.
    Application.ScreenUpdating = False
   
    '2. Присваиваем имя "sh_res" активному листу.
    Set sh_res = ActiveSheet
   
    '3. Открытие файла и присваение ему имени "wb2".
        ' Если из файла нужно извлечь данные, а записать в него не надо,
        ' то нужно использовать "ReadOnly", чтобы было меньше непредсказуемых ситуаций.
    Set wb2 = Workbooks.Open(filename:=FN, ReadOnly:=True)
   
    '4. Копирование данных из листов-источников на лист-результат.
    ' Цикл по листам файла 2.
    For Each sh_src In wb2.Worksheets
   
        ' Если в файле 2, в "B1" заданное значение.
        If sh_src.Range("B1").Value = "Дерево" Then
       
            ' Поиск на листе-результате последней строки.
                ' End не ищет в скрытых строках.
            lr = sh_res.Cells(sh_res.Rows.Count, "A").End(xlUp).row + 1
           
            ' Копирование данных из листа-источника на лист-результат.
            sh_res.Cells(lr, "A").Value = sh_src.Range("B2").Value
            sh_res.Cells(lr, "B").Value = sh_src.Range("B3").Value
            sh_res.Cells(lr, "C").Value = sh_src.Range("B4").Value
            sh_res.Cells(lr, "D").Value = sh_src.Range("B5").Value
            sh_res.Cells(lr, "E").Value = sh_src.Range("B6").Value
           
        End If
       
    Next sh_src
   
    '5. Закрытие файла-источника.
    wb2.Close SaveChanges:=False
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Данные перенесены", vbInformation
   
End Sub

[свернуть]

Примечания

1. Метод "GetOpenFilename" вроде считается устаревшим. Сейчас вместо него используется "Application.FileDialog".
2. Используйте всегда Option Explicit: https://forumvba.ru/index.php?topic=402.0

[gtz]

Вот это круто и красиво. Спасибо!

А можно раскрыть суть:
lr = sh_res.Cells(sh_res.Rows.Count, "A").End(xlUp).row + 1

[Администратор]

End(xlUp) делает то же, что сочетание клавиш Ctrl + стрелка "вверх" в экселе.
А именно, если установить курсор-рамку в столбце самую нижнюю ячейку и нажать сочетание клавиш Ctrl + стрелка "вверх", то курсор-рамка поднимется вверх до первой непустой ячейки.

В экселе в некоторых случаях нет подходящих инструментов. Например в экселе нет инструмента для поиска последней строки с данными.
Это очень удивительно, т.к. эксель считается очень хорошей программой, но инструмента для поиска последней строки с данными программисты из майкрософта почему-то решили не делать.
Они сделали поиск последней строки с учётом оформления, но очень часто на листе есть лишнее оформление и оно не позволяет найти последнюю строку с данными.
Поэтому приходится использовать какие-то инструменты для поиска последней строки, которые предназначены для других задач.

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

[gtz]

спасибо