Здравствуйте, спецы! Помогите пожалуйста с задачкой. В ВБА я полный 0! Есть два файла FIO.xlsx и Phone.xlsx оба содержат столбец с ФИО. Нужно скопировать из Phone.xlsx столбцы телефон и почта в FIO.xlsx лист Сотр. и столбцы Город и ИН в FIO.xlsx лист ИД.
Логику понимаю, а закодировать не могу! Как собака - понимаю, но сказать не могу :-).
На форуме много подобных тем перечитал, но коды из них никак не получается адаптировать под свою задачу, так как не понимаю и не знаю многих команд.
Заранее благодарю!
Здравствуйте, спецы! Помогите пожалуйста с задачкой. В ВБА я полный 0! Есть два файла FIO.xlsx и Phone.xlsx оба содержат столбец с ФИО. Нужно скопировать из Phone.xlsx столбцы телефон и почта в FIO.xlsx лист Сотр. и столбцы Город и ИН в FIO.xlsx лист ИД.
Логику понимаю, а закодировать не могу! Как собака - понимаю, но сказать не могу :-).
На форуме много подобных тем перечитал, но коды из них никак не получается адаптировать под свою задачу, так как не понимаю и не знаю многих команд.
ВПР-ом я делаю, но хотелось-бы сие чудо смонтировать в ВБА, так как файлики по логике совместимы с оригинальными, но данных в них гораздо больше - не хотелось бы в каждую ячейку тулить формулу
ВПР-ом я делаю, но хотелось-бы сие чудо смонтировать в ВБА, так как файлики по логике совместимы с оригинальными, но данных в них гораздо больше - не хотелось бы в каждую ячейку тулить формулуurlchik
Sub pmai() Dim rCell As Range, rng As Range, rTable As Range, lc1&, lc2&
Set rng = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row) On Error Resume Next Dim wb As Workbook: Set wb = Workbooks("Phone.xlsx") 'тут указать ИМЯ книги If Err Then MsgBox "Откройте книгу Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
Set rTable = wb.Worksheets("Лист1").UsedRange 'тут указать ИМЯ листа If Err Then MsgBox "Убедитесь в наличии листа Лист1 в книге Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
For Each rCell In rng If lc1 > 0 Then rCell.Offset(, 2) = WorksheetFunction.VLookup(rCell, rTable, lc1) Else rCell.Offset(, 2) = "Не найден столбец " & [c1] If lc2 > 0 Then rCell.Offset(, 3) = WorksheetFunction.VLookup(rCell, rTable, lc2) Else rCell.Offset(, 3) = "Не найден столбец " & [d1] Next rCell End Sub
[/vba]
Работает только для столбцов С и D. Должна быть открыта книга откуда берутся данные (Phone.xlsx).
Доброго дня! Так хотели? [vba]
Код
Sub pmai() Dim rCell As Range, rng As Range, rTable As Range, lc1&, lc2&
Set rng = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row) On Error Resume Next Dim wb As Workbook: Set wb = Workbooks("Phone.xlsx") 'тут указать ИМЯ книги If Err Then MsgBox "Откройте книгу Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
Set rTable = wb.Worksheets("Лист1").UsedRange 'тут указать ИМЯ листа If Err Then MsgBox "Убедитесь в наличии листа Лист1 в книге Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
Теперь почитаю - как вытягивать данные не открывая книги
Тогда поройте в направлении ExecuteExcel4Macro.
На мой взгляд проще отключить обновление экрана, открыть нужную книгу, а потом закрыть. Например, так:
[vba]
Код
Sub pmai_wbOpen() Dim rCell As Range, rng As Range, rTable As Range, lc1&, lc2&
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet Set rng = ws.Range("a2:a" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row) On Error Resume Next Application.ScreenUpdating = 0 Dim wb As Workbook: Set wb = Workbooks("Phone.xlsx") 'тут указать ИМЯ книги 'если книга не открыта, открыть ее: If Err Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Phone.xlsx"): Err.Clear 'если книги нет в заданной директории ThisWorkbook.Path & "\" If Err Then MsgBox "В папке" & ThisWorkbook.Path & "не обнаружена книга Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
Set rTable = wb.Worksheets("Лист1").UsedRange 'тут указать ИМЯ листа If Err Then MsgBox "Убедитесь в наличии листа Лист1 в книге Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
For Each rCell In rng If lc1 > 0 Then rCell.Offset(, 2) = WorksheetFunction.VLookup(rCell, rTable, lc1) Else rCell.Offset(, 2) = "Не найден столбец " & ws.[c1] If lc2 > 0 Then rCell.Offset(, 3) = WorksheetFunction.VLookup(rCell, rTable, lc2) Else rCell.Offset(, 3) = "Не найден столбец " & ws.[d1] Next rCell 'закрыть книгу "Phone.xlsx" без сохранения wb.Close 0 Application.ScreenUpdating = 1 End Sub
[/vba]
Лично я бы предпочел дать возможность пользователю самому выбирать файл из которого берутся данные:
[vba]
Код
Sub pmai_GetWB() Dim rCell As Range, rng As Range, rTable As Range, lc1&, lc2&
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet Set rng = ws.Range("a2:a" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row) On Error Resume Next Application.ScreenUpdating = 0 Dim wb As Workbook: Set wb = Workbooks.Open(GetOFDWBFullPath("Выберите книгу", ThisWorkbook.Path & "\"))
Set rTable = wb.Worksheets("Лист1").UsedRange 'тут указать ИМЯ листа If Err Then MsgBox "Убедитесь в наличии листа Лист1 в книге Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
For Each rCell In rng If lc1 > 0 Then rCell.Offset(, 2) = WorksheetFunction.VLookup(rCell, rTable, lc1) Else rCell.Offset(, 2) = "Не найден столбец " & ws.[c1] If lc2 > 0 Then rCell.Offset(, 3) = WorksheetFunction.VLookup(rCell, rTable, lc2) Else rCell.Offset(, 3) = "Не найден столбец " & ws.[d1] Next rCell 'закрыть книгу без сохранения wb.Close 0 Application.ScreenUpdating = 1 End Sub
Private Function GetOFDWBFullPath$(Optional strTitle$ = "", Optional strIniFN$ = "") With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = 0 If Len(strTitle) Then .Title = strTitle If Len(strIniFN) Then .InitialFileName = strIniFN If Not .Show = 0 Then GetOFDWBFullPath = .SelectedItems(1) End With End Function
[/vba]
UPD:
вот тут нужно поправить обработку ошибки, правильно так: [vba]
Код
'если книга не открыта, открыть ее: If Err Then Err.Clear: Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Phone.xlsx")
[/vba]
urlchik, в целом да, только в rCell.Offset(, 2) "2" это не номер столбца, а смещение на 2 столбца вправо от текущей ячейки rCell.
Теперь почитаю - как вытягивать данные не открывая книги
Тогда поройте в направлении ExecuteExcel4Macro.
На мой взгляд проще отключить обновление экрана, открыть нужную книгу, а потом закрыть. Например, так:
[vba]
Код
Sub pmai_wbOpen() Dim rCell As Range, rng As Range, rTable As Range, lc1&, lc2&
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet Set rng = ws.Range("a2:a" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row) On Error Resume Next Application.ScreenUpdating = 0 Dim wb As Workbook: Set wb = Workbooks("Phone.xlsx") 'тут указать ИМЯ книги 'если книга не открыта, открыть ее: If Err Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Phone.xlsx"): Err.Clear 'если книги нет в заданной директории ThisWorkbook.Path & "\" If Err Then MsgBox "В папке" & ThisWorkbook.Path & "не обнаружена книга Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
Set rTable = wb.Worksheets("Лист1").UsedRange 'тут указать ИМЯ листа If Err Then MsgBox "Убедитесь в наличии листа Лист1 в книге Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
For Each rCell In rng If lc1 > 0 Then rCell.Offset(, 2) = WorksheetFunction.VLookup(rCell, rTable, lc1) Else rCell.Offset(, 2) = "Не найден столбец " & ws.[c1] If lc2 > 0 Then rCell.Offset(, 3) = WorksheetFunction.VLookup(rCell, rTable, lc2) Else rCell.Offset(, 3) = "Не найден столбец " & ws.[d1] Next rCell 'закрыть книгу "Phone.xlsx" без сохранения wb.Close 0 Application.ScreenUpdating = 1 End Sub
[/vba]
Лично я бы предпочел дать возможность пользователю самому выбирать файл из которого берутся данные:
[vba]
Код
Sub pmai_GetWB() Dim rCell As Range, rng As Range, rTable As Range, lc1&, lc2&
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet Set rng = ws.Range("a2:a" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row) On Error Resume Next Application.ScreenUpdating = 0 Dim wb As Workbook: Set wb = Workbooks.Open(GetOFDWBFullPath("Выберите книгу", ThisWorkbook.Path & "\"))
Set rTable = wb.Worksheets("Лист1").UsedRange 'тут указать ИМЯ листа If Err Then MsgBox "Убедитесь в наличии листа Лист1 в книге Phone.xlsx", vbCritical, "pmaiERR": Exit Sub
For Each rCell In rng If lc1 > 0 Then rCell.Offset(, 2) = WorksheetFunction.VLookup(rCell, rTable, lc1) Else rCell.Offset(, 2) = "Не найден столбец " & ws.[c1] If lc2 > 0 Then rCell.Offset(, 3) = WorksheetFunction.VLookup(rCell, rTable, lc2) Else rCell.Offset(, 3) = "Не найден столбец " & ws.[d1] Next rCell 'закрыть книгу без сохранения wb.Close 0 Application.ScreenUpdating = 1 End Sub
Private Function GetOFDWBFullPath$(Optional strTitle$ = "", Optional strIniFN$ = "") With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = 0 If Len(strTitle) Then .Title = strTitle If Len(strIniFN) Then .InitialFileName = strIniFN If Not .Show = 0 Then GetOFDWBFullPath = .SelectedItems(1) End With End Function
[/vba]
UPD:
вот тут нужно поправить обработку ошибки, правильно так: [vba]
Код
'если книга не открыта, открыть ее: If Err Then Err.Clear: Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Phone.xlsx")
StoTisteg, мое упущение, спасибо за подсказку! Конечно, пользователь же может нажать отмену или крестик диалогового окна, что вернет пустой адрес книги и вызовет ошибку, поэтому после вызова функции нужно добавить: [vba]
Код
If Err Then Exit Sub
[/vba]
StoTisteg, мое упущение, спасибо за подсказку! Конечно, пользователь же может нажать отмену или крестик диалогового окна, что вернет пустой адрес книги и вызовет ошибку, поэтому после вызова функции нужно добавить: [vba]
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
