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

Вход

Регистрация

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

 

= Мир MS Excel/Вытянуть на новый лист, сохранить отдельно, повторить - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вытянуть на новый лист, сохранить отдельно, повторить (Макросы/Sub)
Вытянуть на новый лист, сохранить отдельно, повторить
Dorimar Дата: Четверг, 07.12.2017, 13:52 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте, господа программисты.Необходимо данные из таблицы на листе "ВсеДокументы" занести в данный протокол, опираясь на "Код категории" документа (отмечен красным). По каждой категории имеется от 1 до 12 документов. После успешного занесения данных по одной категории - этот лист должен сохраняться отдельной книгой с именем = коду категории (по адресу "c:\stat\" к примеру), после чего начинается все сначала, но уже по другой категории. Зеленым отмечены места, которые необходимо заполнить, основываясь на листе "ВсеДокументы".
К сообщению приложен файл: 2866408.xlsm(16Kb)


Сообщение отредактировал Dorimar - Четверг, 07.12.2017, 13:53
 
Ответить
СообщениеЗдравствуйте, господа программисты.Необходимо данные из таблицы на листе "ВсеДокументы" занести в данный протокол, опираясь на "Код категории" документа (отмечен красным). По каждой категории имеется от 1 до 12 документов. После успешного занесения данных по одной категории - этот лист должен сохраняться отдельной книгой с именем = коду категории (по адресу "c:\stat\" к примеру), после чего начинается все сначала, но уже по другой категории. Зеленым отмечены места, которые необходимо заполнить, основываясь на листе "ВсеДокументы".

Автор - Dorimar
Дата добавления - 07.12.2017 в 13:52
InExSu Дата: Суббота, 09.12.2017, 23:11 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 260
Репутация: 29 ±
Замечаний: 80% ±

Excel 2010
Привет!
Если бы на листе Протокол не было объединённых ячеек, то можно было бы так:
[vba]
Код
Option Explicit

Sub ОтЧекрыжить_InExSu()
Application.ScreenUpdating = 0
    Dim shW As Worksheet, shT As Worksheet
    Set shW = ActiveWorkbook.Worksheets("ВсеДокументы")
    Set shT = ActiveWorkbook.Worksheets("Шаблон")

    With shW
        .Range("B:B").AdvancedFilter Action:=xlFilterCopy, _
                    CopyToRange:=.Range("L1"), Unique:=True
        Dim arrUniq()
        arrUniq() = .Range("L1").CurrentRegion.Value
        .Range("L:L").Clear
        Dim rng As Range
        Set rng = .[a1].CurrentRegion
        Dim i As Long
        For i = LBound(arrUniq) + 1 To UBound(arrUniq)
            If .FilterMode Then .ShowAllData
            rng.AutoFilter _
                    Field:=2, Criteria1:=CStr(arrUniq(i, 1))
            shT.Range("A9:F" & shT.UsedRange.Rows.Count).Clear
            If .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Count > 10 Then _
               .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Offset(1).Copy _
               shT.Cells(9, 1)
            shT.Range("B9:F" & shT.UsedRange.Rows.Count).Delete _
                    Shift:=xlToLeft
            shT.Range("c5") = CStr(arrUniq(i, 1))
            shT.Copy
            Workbooks.Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs _
                    Filename:="c:\stat\" & CStr(arrUniq(i, 1)), _
                    FileFormat:=xlOpenXMLWorkbook
            ActiveWindow.Close
            Workbooks.Application.DisplayAlerts = True
        Next
    End With
Application.ScreenUpdating = 1
MsgBox "Всё!"
End Sub
[/vba]
К сообщению приложен файл: Dorimar____-_-.xlsb(25Kb)


Сообщение отредактировал InExSu - Суббота, 09.12.2017, 23:15
 
Ответить
СообщениеПривет!
Если бы на листе Протокол не было объединённых ячеек, то можно было бы так:
[vba]
Код
Option Explicit

Sub ОтЧекрыжить_InExSu()
Application.ScreenUpdating = 0
    Dim shW As Worksheet, shT As Worksheet
    Set shW = ActiveWorkbook.Worksheets("ВсеДокументы")
    Set shT = ActiveWorkbook.Worksheets("Шаблон")

    With shW
        .Range("B:B").AdvancedFilter Action:=xlFilterCopy, _
                    CopyToRange:=.Range("L1"), Unique:=True
        Dim arrUniq()
        arrUniq() = .Range("L1").CurrentRegion.Value
        .Range("L:L").Clear
        Dim rng As Range
        Set rng = .[a1].CurrentRegion
        Dim i As Long
        For i = LBound(arrUniq) + 1 To UBound(arrUniq)
            If .FilterMode Then .ShowAllData
            rng.AutoFilter _
                    Field:=2, Criteria1:=CStr(arrUniq(i, 1))
            shT.Range("A9:F" & shT.UsedRange.Rows.Count).Clear
            If .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Count > 10 Then _
               .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Offset(1).Copy _
               shT.Cells(9, 1)
            shT.Range("B9:F" & shT.UsedRange.Rows.Count).Delete _
                    Shift:=xlToLeft
            shT.Range("c5") = CStr(arrUniq(i, 1))
            shT.Copy
            Workbooks.Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs _
                    Filename:="c:\stat\" & CStr(arrUniq(i, 1)), _
                    FileFormat:=xlOpenXMLWorkbook
            ActiveWindow.Close
            Workbooks.Application.DisplayAlerts = True
        Next
    End With
Application.ScreenUpdating = 1
MsgBox "Всё!"
End Sub
[/vba]

Автор - InExSu
Дата добавления - 09.12.2017 в 23:11
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вытянуть на новый лист, сохранить отдельно, повторить (Макросы/Sub)
Страница 1 из 11
Поиск:

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