Автозаполнение ячеек по нескольким критериям из другой книги (скорее всего VBA)

Пользователь

Сообщений: 13 Регистрация: 07.12.2019

09.12.2019 00:26:22

Добрый вечер!

Имеются две книги: в первой книге таблица со значениями, а вторая - та, в которую нужно перенести эти значения.

Таблица в книге 1 (заполненная):
Имя Цель1 Цель2 Цель3 ОбщаяЦель
1
2
3

Таблица в книге 2 (заполнено всё, кроме целей):
Имя Цель1 Описание1 Цель2 Описани2 Цель3 Описание 3 Стоимость ОбщаяЦель

Нужно во вторую книгу вставить значения целей из первой. Примерно представляю, как это должно выглядеть, но не могу написать код, т.к. не умею. Хочется, чтобы задавались два аргумента:
x=название книги
y=название листа
Чтобы было легко редактировать код.
Примеры таблиц приложила. Заранее спасибо!

Прикрепленные файлы

книга1.xlsx (8.8 КБ)
книга2.xlsx (8.38 КБ)

Изменено: astranet - 09.12.2019 00:27:24

Jack Famous

Пользователь

Сообщений: 12058 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

09.12.2019 10:16:55

astranet, здравствуйте!
Выбор файла - через диалоговое окно
Выбор листа - константа в макросе
Вывод нового массива - на новый лист (чтобы не повредить исходные данные)
Чтобы вставлять в исходные данные удалите строку кода №27 Worksheets.Add

Запускать из второй книги

Код

Option Explicit
'====================================================================================================
Sub GetTargetsFromFile()
Dim x, arrFrom, arrNew, txt$, r&, c&
Const shName$ = "Лист1" ' задаём имя листа, с которого нужно забрать данные

txt = ActiveWorkbook.Path
If Not PRDX_ChooseFile(txt) Then Exit Sub
Application.ScreenUpdating = False
Workbooks.Open Filename:=txt, UpdateLinks:=False, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, CorruptLoad:=xlRepairFile

On Error Resume Next
arrFrom = ActiveWorkbook.Worksheets(shName).UsedRange.Value2
If Err Then MsgBox "Лист «" & shName & "» ОТСТУТВУЕТ в выбранном файле!", vbCritical, "ОШИБКА ЛИСТА":       GoTo ex
If Not IsArray(arrFrom) Then MsgBox "На листе «" & shName & "» НЕТ ДАННЫХ!", vbCritical, "ОШИБКА ДАННЫХ":   GoTo ex
On Error GoTo 0
ActiveWorkbook.Close False

arrNew = ActiveSheet.UsedRange.Value2: c = 1
    For Each x In Array(2, 4, 6, 9)
        c = c + 1
        For r = 2 To UBound(arrNew, 1)
            arrNew(r, x) = arrFrom(r, c)
        Next r
    Next x

Worksheets.Add ' удалить или закомментировать, чтобы вставлять в исходные данные, а не на новый лист
Cells(1, 1).Resize(UBound(arrNew, 1), UBound(arrNew, 2)).Value2 = arrNew

ex:
If ActiveWorkbook.FullName <> ThisWorkbook.FullName Then ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub
'====================================================================================================
Private Function PRDX_ChooseFile(DefPath$) As Boolean ' функция для выбора файла

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Выберите Excel-файлы"
        .Filters.Clear
        .Filters.Add "Файлы Excel", "*.xls?", 1
        .FilterIndex = 1
        .InitialFileName = DefPath
        .InitialView = msoFileDialogViewDetails
        If .Show = 0 Then Exit Function
        DefPath = .SelectedItems(1)
    End With

PRDX_ChooseFile = True
End Function
'====================================================================================================

Прикрепленные файлы

книга2.xlsb (20.1 КБ)

Изменено: Jack Famous - 09.12.2019 10:19:43

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

Kuzmich

Пользователь

Сообщений: 8050 Регистрация: 21.12.2012

09.12.2019 12:11:57

astranet,
Макрос в стандартный модуль Книга1, обе книги должны быть открыты

Код

Sub PernosTarget()
Dim j As Long
Dim iLastRow As Long
Dim iLastCol As Integer
Dim Sh_Kniga2 As Worksheet
Dim FoundTag As Range
Application.ScreenUpdating = False
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
  Set Sh_Kniga2 = Workbooks("Книга2.xls").Worksheets("Лист1")
  With Sh_Kniga2
   For j = 2 To iLastCol
    Set FoundTag = .Rows(1).Find(Cells(1, j), , xlValues, xlWhole)
     Range(Cells(2, j), Cells(iLastRow, j)).Copy
     .Cells(2, FoundTag.Column).PasteSpecial xlValues
   Next
     .Activate
     .Range("A1").Select
  End With
Application.ScreenUpdating = True
End Sub