Здравствуйте, необходимо создавать архив, в котором будут содержаться определенные значения из множества книг, находящихся в одной папке. В каждой такой книге есть лист "Вывод данных", можно ли в отдельный файл записать значения только с этого листа, не из всей книги? Есть следующий макрос:
[vba]
Код
Sub Собираем_данные()
Dim iRng As Range Dim iRngAddress As String, oAwb As String, oFile Dim lLastRow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String
With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub For Each oFile In .SelectedItems Workbooks.OpenText fileName:=oFile oAwb = Dir(oFile, vbDirectory)
Он записывает все листы, пытаюсь переделать его чтоб записывать только этот лист из каждой книги, но безуспешно. Реально переделать этот или нужно совершенно другой? Возможно ли вообще записывать только 1 лист из книги?
Примеры книг ниже
Здравствуйте, необходимо создавать архив, в котором будут содержаться определенные значения из множества книг, находящихся в одной папке. В каждой такой книге есть лист "Вывод данных", можно ли в отдельный файл записать значения только с этого листа, не из всей книги? Есть следующий макрос:
[vba]
Код
Sub Собираем_данные()
Dim iRng As Range Dim iRngAddress As String, oAwb As String, oFile Dim lLastRow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String
With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub For Each oFile In .SelectedItems Workbooks.OpenText fileName:=oFile oAwb = Dir(oFile, vbDirectory)
Он записывает все листы, пытаюсь переделать его чтоб записывать только этот лист из каждой книги, но безуспешно. Реально переделать этот или нужно совершенно другой? Возможно ли вообще записывать только 1 лист из книги?
Dim iRng As Range Dim iRngAddress As String, oAwb As String, oFile Dim lLastRow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String
With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub For Each oFile In .SelectedItems Workbooks.OpenText fileName:=oFile oAwb = Dir(oFile, vbDirectory)
Dim iRng As Range Dim iRngAddress As String, oAwb As String, oFile Dim lLastRow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String
With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub For Each oFile In .SelectedItems Workbooks.OpenText fileName:=oFile oAwb = Dir(oFile, vbDirectory)
Нужно было старый пост поправить. Но, посколько через сутки Вы уже не можете его редактировать, то просто написали бы в посте, я бы попрвавил.
А макрос я Вам еще вчера сделал [vba]
Код
Sub Собираем_данные() Dim iRng As Range Dim iRngAddress As String, oAwb As String, oFile Dim lLastRow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub Application.ScreenUpdating = False On Error Resume Next For Each oFile In .SelectedItems Workbooks.OpenText Filename:=oFile oAwb = Dir(oFile, vbDirectory) Err.Clear Sheets("Вывод данных").Activate If Err = 0 Then lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row + 1 iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address Sheets("Вывод данных").Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress) End If Workbooks(oAwb).Close False Next oFile End With Application.ScreenUpdating = True End Sub
[/vba]
Нужно было старый пост поправить. Но, посколько через сутки Вы уже не можете его редактировать, то просто написали бы в посте, я бы попрвавил.
А макрос я Вам еще вчера сделал [vba]
Код
Sub Собираем_данные() Dim iRng As Range Dim iRngAddress As String, oAwb As String, oFile Dim lLastRow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub Application.ScreenUpdating = False On Error Resume Next For Each oFile In .SelectedItems Workbooks.OpenText Filename:=oFile oAwb = Dir(oFile, vbDirectory) Err.Clear Sheets("Вывод данных").Activate If Err = 0 Then lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row + 1 iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address Sheets("Вывод данных").Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress) End If Workbooks(oAwb).Close False Next oFile End With Application.ScreenUpdating = True End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
