Страницы: 1
RSS
Перенос данных из ячеек значениями из одной книги в другую - VBA
 
Добрый день.
На работе появился процесс, который хочется автоматизировать, но не знаю как.
Есть 2 книги Excel. Первая с исходной информацией (Сверка), второй - конечный файл (БРЗ). В данных книгах большое количество листов - около 200. Названия этих листов в первой книге такое же как и во второй. В книге "Сверка" есть лист "Перенос в БРЗ". На данной листе указываются технические параметры для работы будущего макроса, а именно:
1. Путь к файлу, в который необходимо перенести данные;
2. Список листов, которые нужно найти в книге "БРЗ". В книге "Сверка" листы называются точно так же. Их количество может увеличиваться или уменьшаться. Порядок так же может меняться;
3. Адреса данных, которые нужно перенести в книгу "БРЗ";
4. Месяц. От Выбора месяца (будет выпадающий список) будет зависеть столбец в файле "БРЗ", в который будут перенесены значения. Другие столбцы должны будут остаться без изменений;
5. Строки в файле "БРЗ", в которых находятся ячейки, в которые нужно вставить данные.

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

Использовать связи в данном случае нельзя.
Оба файла прикрепляю.

Пока смог написать только такое:
Код
Option Explicit

Sub Перенос_данных_в_БРЗ()

Dim oRange As Range
'Указывает путь в файлу БРЗ
Set oRange = Worksheets("ПЕРЕНОС в БРЗ").Range("C2")

'Открываем файл с БРЗ
Workbooks.Open Filename:=oRange

Dim sh As Worksheet

Dim lists As Range
Set lists = Workbooks("Сверка.xlsb").Worksheets("ПЕРЕНОС в БРЗ").Range("C5")

For Each sh In Worksheets
If sh.Name = lists Then Exit For
MsgBox ("Good!")

Next
If sh Is Nothing Then MsgBox "Лист " & lists & " не найден": Exit Sub
End Sub
Спасибо.
 
Книги в переменные:
Код
Set tWB=ThisWorkBook
Set nWB=WorkBooks.Open(FilePart & FileName)
Список имен либо в массив руками:
Код
SHlist=Array("Shhet1","Sheet2",...)
Либо организовать цикл по листам со сверкой их названий (лист с одним и тем-же названием присутствует в обеих книгах):
Код
For Each shA in tWB
  For Each shB in nWB
    If shA.Name=shB.Name Then
      If Not IsArray(arr) Then
        Redim arr(1 to 1):arr(1)=shA.Name:Exit For
      Else
        ReDim Preserve arr(1 to Ubound(arr)+1)
        arr(Ubound(arr))=shA.Name:Exit For
      End If
    End If
  Next
Next
 
Спасибо. Не могу понять почему появляется ошибка:
Код
Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

Dim nWB As Range
'Указываем путь в файлу БРЗ
Set nWB = Worksheets("ПЕРЕНОС в БРЗ").Range("C2")

'Открываем файл с БРЗ
Workbooks.Open Filename:=nWB

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr() As String

For Each shA In tWB
  For Each shB In nWB
    If shA.Name = shB.Name Then
      If Not IsArray(arr) Then
        ReDim arr(1 To 1): arr(1) = shA.Name: Exit For
      Else
        ReDim Preserve arr(1 To UBound(arr) + 1)
        arr(UBound(arr)) = shA.Name: Exit For
      End If
    End If
  Next
Next

End Sub
Изменено: iromanvasilyev - 25.03.2018 11:21:29
 
Цитата
iromanvasilyev написал:
почему появляется ошибка:
Вот поэтому.
Код
Set nWB = Worksheets("ПЕРЕНОС в БРЗ").Range("C2")
 
'Открываем файл с БРЗ
Workbooks.Open Filename:=nWB
 
Все равно, до цикла дошел и ошибка:
Код
Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

Dim nWB As Variant
'Указываем путь в файлу БРЗ
Set nWB = Workbooks.Open(Filename:="D:\VB\Перенос значений\БРЗ.xlsx")

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr() As String

For Each shA In tWB
  For Each shB In nWB
    If shA.Name = shB.Name Then
      If Not IsArray(arr) Then
        ReDim arr(1 To 1): arr(1) = shA.Name: Exit For
      Else
        ReDim Preserve arr(1 To UBound(arr) + 1)
        arr(UBound(arr)) = shA.Name: Exit For
      End If
    End If
  Next
Next

End Sub
 
iromanvasilyev,сорри:
Код
Dim arr
For Each shA In tWB.sheets
  For Each shB In nWB.sheets
Изменено: Anchoret - 25.03.2018 11:48:51
 
Anchoret, спасибо. ошибка не появляется. А что делает 18, 19, 21 и 22 строчки?
 
iromanvasilyev,а на что это похоже? Определяют массив/не массив, создают/расширяют массив (расширение возможно только для последнего измерения массива и только по второму параметру - например ReDim Preserve arr(1 to n)).
На самом деле, если у Вас в обоих файлах перенос идет по жестким диапазонам, то проще через:
Код
arr=array("sh1.name","диапазон1","диапазон2","*","sh2.name", и т.д..)

Звездочка в качестве определителя конца входных данных для конкретного листа. Разумеется условие этого определения нужно прописать в коде.

Изменено: Anchoret - 25.03.2018 12:54:36
 
Маленькая деталь по коду: sheets<>worksheets, на этом можете получить ошибку, если в книги будут не только рабочие листы.
 
Hugo,в книге есть не только рабочие листы. Пока пытаюсь написать так, чтобы после того, как цикл найдет лист, копировались значения с этого листа на лист с таким же названием во второй книге в соответствующую ячейку.
 
Начинает получаться. Помогите разобраться почему цикл For после успешного поиска первого листа (совпадение в названии в двух книгах) и вставки значений куда нужно, не переходит к такой же задаче на следующем листе?
Код
Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

'Указываем путь в файлу БРЗ
Dim nWB As Variant
Set nWB = Workbooks.Open(Filename:="D:\VB\Перенос значений\БРЗ.xlsx")

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr

For Each shA In tWB.Sheets 'лист в Сверке
   For Each shB In nWB.Sheets 'лист в БРЗ
    If shA.Name = shB.Name Then
        If Not IsArray(arr) Then
            ReDim arr(1 To 1): arr(1) = shA.Name
                shA.Range("B4").Copy
                shB.Activate
                shB.Range("C4").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("C4").Copy
                shB.Activate
                shB.Range("C5").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("D4").Copy
                shB.Activate
                shB.Range("C6").PasteSpecial xlPasteValues: Exit For
    Else
        ReDim Preserve arr(1 To UBound(arr) + 1)
            arr(UBound(arr)) = shA.Name
                MsgBox ("Такого листа нет в БРЗ")
        End If
    End If
  Next
Next

End Sub
И не могу понять, почему итерации второго и третьего листов появляется msgbox, ведь листы называются так же.

Даже, когда цикл видит, что Лист "Признак 2" из одной книги равен "Признак 2" из другой, все равно он исполняет "Иначе".

Если часть кода закомментрировать, то цикл работает, но вариант с "Иначе" работает неправильно:
Код
Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

'Указываем путь в файлу БРЗ
Dim nWB As Variant
Set nWB = Workbooks.Open(Filename:="D:\VB\Перенос значений\БРЗ.xlsx")

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr

For Each shA In tWB.Sheets 'лист в Сверке
   For Each shB In nWB.Sheets 'лист в БРЗ
    If shA.Name = shB.Name Then
        'If Not IsArray(arr) Then
            'ReDim arr(1 To 1): arr(1) = shA.Name
                shA.Range("B4").Copy
                shB.Activate
                shB.Range("C4").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("C4").Copy
                shB.Activate
                shB.Range("C5").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("D4").Copy
                shB.Activate
                shB.Range("C6").PasteSpecial xlPasteValues ': Exit For
    Else
        'ReDim Preserve arr(1 To UBound(arr) + 1)
            'arr(UBound(arr)) = shA.Name
                MsgBox ("Такого листа нет в БРЗ") 'ПОЯВЛЯЕТСЯ КАЖДЫЙ РАЗ ПРИ СОПОСТОВЛЕНИИ РАЗНЫХ ЛИСТОВ. НАДО ЧТОБЫ ПОЯВЛЯЛСЯ, КОГДА ЛИСТА НЕТ В КНИГЕ
        End If
    'End If
  Next
Next

End Sub
Изменено: iromanvasilyev - 26.03.2018 19:44:35
 
Забудьте про Activate и Select. Первая проверка на массив/не массив срабатывает только один раз, потом идет расширение массива и запись названий новых листов. Вот и думайте)
Да, и раз у Вас там не только рабочие листы, но и диаграммы всякие, то и цикл делайте соответствующим:
Код
For Each shA in Nwb.WorkSheets

П.С.: Старайтесь скрывать под спойлерами портянки листингов.
Изменено: Anchoret - 26.03.2018 21:46:55
Страницы: 1
Наверх