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

Вход

Регистрация

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

 

= Мир MS Excel/Сохранение отдельными файлами по одинаковому значению из сто - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Сохранение отдельными файлами по одинаковому значению из сто
Obbyqw Дата: Понедельник, 21.10.2024, 09:07 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Добрый день! Имеется таблица с большим количеством строк. Необходимо разбить этот файл на файлы по одинаковому значению из ячейки D и сохранить с названием с этой ячейки (по примеру, файл 10000 и в нем только данные (фио, табель и остальные) из этой группы, второй файл 10001 и тд, итого на выходе 4 файла). Заранее благодарю!
К сообщению приложен файл: list_microsoft_excel_2.xlsx (9.6 Kb)
 
Ответить
СообщениеДобрый день! Имеется таблица с большим количеством строк. Необходимо разбить этот файл на файлы по одинаковому значению из ячейки D и сохранить с названием с этой ячейки (по примеру, файл 10000 и в нем только данные (фио, табель и остальные) из этой группы, второй файл 10001 и тд, итого на выходе 4 файла). Заранее благодарю!

Автор - Obbyqw
Дата добавления - 21.10.2024 в 09:07
MikeVol Дата: Понедельник, 21.10.2024, 09:33 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 373
Репутация: 79 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
Obbyqw, Как вас понял, вариант. [vba]
Код
Option Explicit

Sub Split_WB()
    Dim c As Range, k As Variant

    Dim ws          As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    With ThisWorkbook.Worksheets("Sheet1")

        Dim rg      As Range
        Set rg = .Range("D6:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    End With

    With CreateObject("Scripting.Dictionary")

        For Each c In rg
            .Item(c.Value) = Empty
        Next c

        For Each k In .keys

            Dim wb  As Workbook
            Set wb = Workbooks.Add

            With ws
                .Cells(6, 4).CurrentRegion.AutoFilter Field:=1, Criteria1:=k
                .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy

                Dim wsNew As Worksheet
                Set wsNew = wb.Sheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))

                With wsNew
                    .Name = k
                    .Cells(1).PasteSpecial xlPasteAll
                End With

                .AutoFilterMode = False
            End With

            wb.Worksheets(1).Delete
            wb.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
            wb.Close False
        Next k

    End With

    Set wsNew = Nothing
    Set wb = Nothing
    Set rg = Nothing
    Set ws = Nothing

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

    MsgBox " Шеф, Усё, Клиент готов! "
End Sub
[/vba]Удачи.


Ученик.
Одесса - Украина


Сообщение отредактировал MikeVol - Понедельник, 21.10.2024, 09:49
 
Ответить
СообщениеObbyqw, Как вас понял, вариант. [vba]
Код
Option Explicit

Sub Split_WB()
    Dim c As Range, k As Variant

    Dim ws          As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    With ThisWorkbook.Worksheets("Sheet1")

        Dim rg      As Range
        Set rg = .Range("D6:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    End With

    With CreateObject("Scripting.Dictionary")

        For Each c In rg
            .Item(c.Value) = Empty
        Next c

        For Each k In .keys

            Dim wb  As Workbook
            Set wb = Workbooks.Add

            With ws
                .Cells(6, 4).CurrentRegion.AutoFilter Field:=1, Criteria1:=k
                .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy

                Dim wsNew As Worksheet
                Set wsNew = wb.Sheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))

                With wsNew
                    .Name = k
                    .Cells(1).PasteSpecial xlPasteAll
                End With

                .AutoFilterMode = False
            End With

            wb.Worksheets(1).Delete
            wb.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
            wb.Close False
        Next k

    End With

    Set wsNew = Nothing
    Set wb = Nothing
    Set rg = Nothing
    Set ws = Nothing

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

    MsgBox " Шеф, Усё, Клиент готов! "
End Sub
[/vba]Удачи.

Автор - MikeVol
Дата добавления - 21.10.2024 в 09:33
  • Страница 1 из 1
  • 1
Поиск:

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