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

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Скопировать таблицу по кнопке в отдельный файл. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Скопировать таблицу по кнопке в отдельный файл. (Макросы/Sub)
Скопировать таблицу по кнопке в отдельный файл.
Mark1976 Дата: Воскресенье, 26.11.2017, 22:03 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 433
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Всем здравствуйте. У меня есть много файлов. В каждом из них разное количество строк. Но одна таблица присутствует всегда (залита желтым цветом первая ячейка N262 в моем примере). Мне необходимо таблицу скопировать в отдельный файл (ЖО_7_свод) название листа взять из ячейки F3. Т.е. в файле ЖО_7_свод должны быть листы из файлов источников. Буду признателен за помощь.
К сообщению приложен файл: 01_2016.xlsx(61Kb) · _7_.xlsx(10Kb)
 
Ответить
СообщениеВсем здравствуйте. У меня есть много файлов. В каждом из них разное количество строк. Но одна таблица присутствует всегда (залита желтым цветом первая ячейка N262 в моем примере). Мне необходимо таблицу скопировать в отдельный файл (ЖО_7_свод) название листа взять из ячейки F3. Т.е. в файле ЖО_7_свод должны быть листы из файлов источников. Буду признателен за помощь.

Автор - Mark1976
Дата добавления - 26.11.2017 в 22:03
alex77755 Дата: Понедельник, 27.11.2017, 17:17 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 333
Репутация: 60 ±
Замечаний: 0% ±

как-то так:
[vba]
Код
Option Explicit

Sub собрать_таблицы()
    Dim wb As Workbook
    Dim wbi, per$, est
    Dim pt0, pat, fil, nt, cn, ck, kt, rx As Range
    Set wb = ActiveWorkbook
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    pt0 = ActiveWorkbook.Path
    fil = Dir(pt0 & "\*.xls*")
    Do While Len(fil) > 0
        Debug.Print fil
        If fil <> wb.Name Then
            Set wbi = Workbooks.Open(pt0 & "\" & fil).Worksheets(1)
            With wbi
                Set rx = .Cells.Find("Обороты для главной книги")
                If Not rx Is Nothing Then
                    nt = rx.Row
                    cn = rx.Column
                    ck = cn + rx.MergeArea.Count - 1
                    Set rx = .Cells.Find("итого по журналу операций")
                    If Not rx Is Nothing Then
                       kt = rx.Row
                       per = .[f3]
                        est = ЛИСТСУЩ(per)
                        If est Then
                            MsgBox "Дубль периода " & per, vbCritical, ""
                        Else
                            With wb.Worksheets.Add
                    .Name = per
                    wbi.Cells(nt, cn).Resize(kt - nt + 1, ck - cn + 1).Copy wb.Worksheets(per).Cells(1, 1)
                            End With
                        End If
                    End If
                
                End If
            End With
      
            wbi.Parent.Close
        End If
    fil = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Function ЛИСТСУЩ(ИМЯ As String) As Boolean
    Dim Sh As Object
    On Error Resume Next
    Set Sh = ActiveWorkbook.Sheets(ИМЯ)
    If Err.Number = 0 Then ЛИСТСУЩ = True
End Function
[/vba]


Могу помочь в VB6, VBA
Alex77755@mail.ru
 
Ответить
Сообщениекак-то так:
[vba]
Код
Option Explicit

Sub собрать_таблицы()
    Dim wb As Workbook
    Dim wbi, per$, est
    Dim pt0, pat, fil, nt, cn, ck, kt, rx As Range
    Set wb = ActiveWorkbook
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    pt0 = ActiveWorkbook.Path
    fil = Dir(pt0 & "\*.xls*")
    Do While Len(fil) > 0
        Debug.Print fil
        If fil <> wb.Name Then
            Set wbi = Workbooks.Open(pt0 & "\" & fil).Worksheets(1)
            With wbi
                Set rx = .Cells.Find("Обороты для главной книги")
                If Not rx Is Nothing Then
                    nt = rx.Row
                    cn = rx.Column
                    ck = cn + rx.MergeArea.Count - 1
                    Set rx = .Cells.Find("итого по журналу операций")
                    If Not rx Is Nothing Then
                       kt = rx.Row
                       per = .[f3]
                        est = ЛИСТСУЩ(per)
                        If est Then
                            MsgBox "Дубль периода " & per, vbCritical, ""
                        Else
                            With wb.Worksheets.Add
                    .Name = per
                    wbi.Cells(nt, cn).Resize(kt - nt + 1, ck - cn + 1).Copy wb.Worksheets(per).Cells(1, 1)
                            End With
                        End If
                    End If
                
                End If
            End With
      
            wbi.Parent.Close
        End If
    fil = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Function ЛИСТСУЩ(ИМЯ As String) As Boolean
    Dim Sh As Object
    On Error Resume Next
    Set Sh = ActiveWorkbook.Sheets(ИМЯ)
    If Err.Number = 0 Then ЛИСТСУЩ = True
End Function
[/vba]

Автор - alex77755
Дата добавления - 27.11.2017 в 17:17
Mark1976 Дата: Среда, 29.11.2017, 20:33 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 433
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
alex77755, спасибо за решение. Немного не понял как макрос работает. Я так понимаю, он собирает данные из файлов, которые находятся в отдельной папке?
 
Ответить
Сообщениеalex77755, спасибо за решение. Немного не понял как макрос работает. Я так понимаю, он собирает данные из файлов, которые находятся в отдельной папке?

Автор - Mark1976
Дата добавления - 29.11.2017 в 20:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Скопировать таблицу по кнопке в отдельный файл. (Макросы/Sub)
Страница 1 из 11
Поиск:

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