Obbyqw
Дата: Понедельник, 21.10.2024, 09:07 |
Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация:
0
±
Замечаний:
0% ±
Добрый день! Имеется таблица с большим количеством строк. Необходимо разбить этот файл на файлы по одинаковому значению из ячейки D и сохранить с названием с этой ячейки (по примеру, файл 10000 и в нем только данные (фио, табель и остальные) из этой группы, второй файл 10001 и тд, итого на выходе 4 файла). Заранее благодарю!
Добрый день! Имеется таблица с большим количеством строк. Необходимо разбить этот файл на файлы по одинаковому значению из ячейки D и сохранить с названием с этой ячейки (по примеру, файл 10000 и в нем только данные (фио, табель и остальные) из этой группы, второй файл 10001 и тд, итого на выходе 4 файла). Заранее благодарю! Obbyqw
Ответить
Сообщение Добрый день! Имеется таблица с большим количеством строк. Необходимо разбить этот файл на файлы по одинаковому значению из ячейки 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]Удачи.
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
Ученик. Одесса - Украина
Сообщение отредактировал 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