Версия для слабовидящих
Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

 

= Мир MS Excel/Запись данных из определенных листов в книгах - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Запись данных из определенных листов в книгах (Формулы/Formulas)
Запись данных из определенных листов в книгах
Nikita95 Дата: Понедельник, 25.09.2017, 12:40 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте, необходимо создавать архив, в котором будут содержаться определенные значения из множества книг, находящихся в одной папке. В каждой такой книге есть лист "Вывод данных", можно ли в отдельный файл записать значения только с этого листа, не из всей книги? Есть следующий макрос:

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)

Application.ScreenUpdating = False
Workbooks(oAwb).Activate
For Each Sheet In Sheets
Sheet.Activate
lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column
lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row
iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address
Sheet.Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress)

Next Sheet
Workbooks(oAwb).Close False
Next oFile

End With

Application.ScreenUpdating = True
End Sub



Он записывает все листы, пытаюсь переделать его чтоб записывать только этот лист из каждой книги, но безуспешно. Реально переделать этот или нужно совершенно другой? Возможно ли вообще записывать только 1 лист из книги?

Примеры книг ниже
К сообщению приложен файл: 2962420.xls (75.5 Kb) · -_23.xls (86.5 Kb)


Сообщение отредактировал Nikita95 - Понедельник, 25.09.2017, 12:41
 
Ответить
СообщениеЗдравствуйте, необходимо создавать архив, в котором будут содержаться определенные значения из множества книг, находящихся в одной папке. В каждой такой книге есть лист "Вывод данных", можно ли в отдельный файл записать значения только с этого листа, не из всей книги? Есть следующий макрос:

[vba]
Sub Собираем_данные()Dim iRng As RangeDim iRngAddress As String; oAwb As String; oFileDim lLastRow As Long; lLastRowMyBook As LongDim iLastColumn As IntegerDim Str() As StringWith Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = Тrue.InitialFileName = "*.*".Title = "Выберите файлы"If .Show = False Then Exit SubFor Each oFile In .SelectedItemsWorkbooks.OpenText fileName:=oFileoAwb = Dir(oFile; vbDirectory)Application.ScreenUpdating = FalseWorkbooks(oAwb).ActivateFor Each Sheet In SheetsSheet.ActivatelLastRow = Cells(1; 1).SpecialCells(xlLastCell).RowiLastColumn = Cells(1; 1).SpecialCells(xlLastCell).ColumnlLastRowMyBook = ТhisWorkbook.Worksheets(1).Cells(100; 1).SpecialCells(xlLastCell).RowiRngAddress = Range(Cells(lLastRowMyBook; 1); Cells(lLastRowMyBook + lLastRow; iLastColumn)).AddressSheet.Range(Cells(1; 1); Cells(lLastRow; iLastColumn)).Copy Destination:=ТhisWorkbook.Worksheets(1).Range(iRngAddress)Next SheetWorkbooks(oAwb).Close FalseNext oFileEnd WithApplication.ScreenUpdating = ТrueEnd Sub
[/vba]

Он записывает все листы, пытаюсь переделать его чтоб записывать только этот лист из каждой книги, но безуспешно. Реально переделать этот или нужно совершенно другой? Возможно ли вообще записывать только 1 лист из книги?

Примеры книг ниже
Автор - Nikita95
Дата добавления - 25.09.2017 в 12:40
_Boroda_ Дата: Понедельник, 25.09.2017, 13:19 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16888
Репутация: 6611 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
Прочитайте Правила форума
Оформите код тегами (кнопка # в режиме правки поста)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПрочитайте Правила форума
Оформите код тегами (кнопка # в режиме правки поста)
Автор - _Boroda_
Дата добавления - 25.09.2017 в 13:19
Nikita95 Дата: Вторник, 26.09.2017, 14:14 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010


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)

Application.ScreenUpdating = False
Workbooks(oAwb).Activate
For Each Sheet In Sheets
Sheet.Activate
lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column
lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row
iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address
Sheet.Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress)

Next Sheet
Workbooks(oAwb).Close False
Next oFile

End With

Application.ScreenUpdating = True
End Sub

 
Ответить
Сообщение[vba]
Sub Собираем_данные()Dim iRng As RangeDim iRngAddress As String; oAwb As String; oFileDim lLastRow As Long; lLastRowMyBook As LongDim iLastColumn As IntegerDim Str() As StringWith Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = Тrue.InitialFileName = "*.*".Title = "Выберите файлы"If .Show = False Then Exit SubFor Each oFile In .SelectedItemsWorkbooks.OpenText fileName:=oFileoAwb = Dir(oFile; vbDirectory)Application.ScreenUpdating = FalseWorkbooks(oAwb).ActivateFor Each Sheet In SheetsSheet.ActivatelLastRow = Cells(1; 1).SpecialCells(xlLastCell).RowiLastColumn = Cells(1; 1).SpecialCells(xlLastCell).ColumnlLastRowMyBook = ТhisWorkbook.Worksheets(1).Cells(100; 1).SpecialCells(xlLastCell).RowiRngAddress = Range(Cells(lLastRowMyBook; 1); Cells(lLastRowMyBook + lLastRow; iLastColumn)).AddressSheet.Range(Cells(1; 1); Cells(lLastRow; iLastColumn)).Copy Destination:=ТhisWorkbook.Worksheets(1).Range(iRngAddress)Next SheetWorkbooks(oAwb).Close FalseNext oFileEnd WithApplication.ScreenUpdating = ТrueEnd Sub
[/vba]
Автор - Nikita95
Дата добавления - 26.09.2017 в 14:14
_Boroda_ Дата: Вторник, 26.09.2017, 15:02 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 16888
Репутация: 6611 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
Нужно было старый пост поправить. Но, посколько через сутки Вы уже не можете его редактировать, то просто написали бы в посте, я бы попрвавил.

А макрос я Вам еще вчера сделал

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

К сообщению приложен файл: 41849785.xlsm (12.6 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеНужно было старый пост поправить. Но, посколько через сутки Вы уже не можете его редактировать, то просто написали бы в посте, я бы попрвавил.

А макрос я Вам еще вчера сделал
[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 = Тrue        .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 = ТhisWorkbook.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:=ТhisWorkbook.Worksheets(1).Range(iRngAddress)            End If            Workbooks(oAwb).Close False        Next oFile    End With    Application.ScreenUpdating = ТrueEnd Sub
[/vba]
Автор - _Boroda_
Дата добавления - 26.09.2017 в 15:02
Nikita95 Дата: Среда, 27.09.2017, 06:08 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
_Boroda_, Спасибо Вам!
 
Ответить
Сообщение_Boroda_, Спасибо Вам!
Автор - Nikita95
Дата добавления - 27.09.2017 в 06:08
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Запись данных из определенных листов в книгах (Формулы/Formulas)
  • Страница 1 из 1
  • 1
Поиск:

Рейтинг@Mail.ru Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!