Макросы в excel разделение

Разделение таблицы по листам

В Microsoft Excel есть много инструментов для сборки данных из нескольких таблиц (с разных листов или из разных файлов): прямые ссылки, функция ДВССЫЛ (INDIRECT), надстройки Power Query и Power Pivot и т.д. С этой стороны баррикад всё выглядит неплохо.

Но если вы нарвётесь на обратную задачу — разнесения данных из одной таблицы на разные листы — то всё будет гораздо печальнее. На сегодняшний момент цивилизованных встроенных инструментов для такого разделения данных в арсенале Excel, к сожалению, нет. Так что придется задействовать макрос на Visual Basic, либо воспольоваться связкой макрорекордер+Power Query с небольшой «доработкой напильником» после.

Давайте подробно рассмотрим, как это можно реализовать.

Постановка задачи

Имеем в качестве исходных данных вот такую таблицу размером больше 5000 строк по продажам:

Задача: разнести данные из этой таблицы по городам на отдельные листы этой книги. Т.е. на выходе нужно получить на каждом листе только те строки из таблицы, где продажа была в соответствующем городе:

Подготовка

Чтобы не усложнять код макроса и сделать его максимально простым для понимания, выполним пару подготовительных действий.

Во-первых, создадим отдельную таблицу-справочник, где в единственном столбце будут перечислены все города, для которых нужно создать отдельные листы. Само-собой, в этом справочнике могут быть не все города, присутствующие в исходных данных, а только те, по которым нам нужны отчеты. Проще всего создать такую таблицу, используя команду Данные — Удалить дубликаты (Data — Remove duplicates) для копии столбца Город или функцию УНИК (UNIQUE) — если у вас последняя версия Excel 365.

Поскольку новые листы в Excel по умолчанию создаются перед (левее) текущего (предыдущего), то имеет смысл также отсортировать города в этом справочнике по убыванию (от Я до А) — тогда после создания листы-города расположатся по алфавиту.

Во-вторых, преобразуем обе таблицы в динамические («умные»), чтобы с ними было проще работать. Используем команду Главная — Форматировать как таблицу (Home — Format as Table) или сочетание клавиш Ctrl+T. На появившейся вкладке Конструктор (Design) назовём их таблПродажи и таблГорода, соответственно:

Способ 1. Макрос для деления по листам

На вкладке Разработчик (Developer) нажмите на кнопку Visual Basic или используйте сочетание клавиш Alt+F11. В открывшемся окне редактора макросов вставьте новый пустой модуль через меню Insert — Module и скопируйте туда следующий код:

Sub Splitter()
    For Each cell In Range("таблГорода")
        Range("таблПродажи").AutoFilter Field:=3, Criteria1:=cell.Value
        Range("таблПродажи[#All]").SpecialCells(xlCellTypeVisible).Copy
        Sheets.Add
        ActiveSheet.Paste
        ActiveSheet.Name = cell.Value
        ActiveSheet.UsedRange.Columns.AutoFit
    Next cell
    Worksheets("Данные").ShowAllData
End Sub	

Здесь с помощью цикла For Each … Next реализован проход по ячейкам справочника таблГорода, где для каждого города происходит его фильтрация (метод AutoFilter) в исходной таблице продаж и затем копирование результатов на новый созданный лист. Попутно созданный лист переименовывается в то же имя города и на нем включается автоподбор ширины столбцов для красоты.

Запустить созданный макрос в Excel можно на вкладке Разработчик кнопкой Макросы (Developer — Macros) или сочетанием клавиш Alt+F8.

Способ 2. Создаем множественные запросы в Power Query

У предыдущего способа, при всей его компактности и простоте, есть существенный недостаток — созданные макросом листы не обновляются при изменениях в исходной таблице продаж. Если обновление «на лету» необходимо, то придется использовать связку VBA+Power Query, а точнее — создавать с помощью макроса не просто листы со статическими данными, а обновляемые запросы Power Query.

Макрос в этом случае частично похож на предыдущий (в нём тоже есть цикл For Each … Next для перебора городов в справочнике), но внутри цикла будет уже не фильтрация и копирование, а создание запроса Power Query и выгрузка его результатов на новый лист:

Sub Splitter2()

For Each cell In Range("таблГорода")
    ActiveWorkbook.Queries.Add Name:=cell.Value, Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Источник = Excel.CurrentWorkbook(){[Name=""таблПродажи""]}[Content]," & Chr(13) & "" & Chr(10) & "    #""Измененный тип"" = Table.TransformColumnTypes(Источник,{{""Категория"", type text}, {""Наименование"", type text}, {""Город"", type text}, {""Менеджер"", type text}, {""Дата сделки"", type datetime}, {""Стоимость"", type number}})," & Chr(13) & "" & Chr(10) & "    #""Строки с примененным фильтром"" = Table.Se" & _
        "lectRows(#""Измененный тип"", each ([Город] = """ & cell.Value & """))" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Строки с примененным фильтром"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & cell.Value & ";Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [" & cell.Value & "]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = cell.Value
        .Refresh BackgroundQuery:=False
    End With
    ActiveSheet.Name = cell.Value
Next cell
End Sub

После его запуска мы увидим те же листы по городам, но формировать их будут уже созданные запросы Power Query:

При любых изменениях в исходных данных достаточно будет обновить соответствующую таблицу правой кнопкой мыши — команда Обновить (Refresh) или обновить сразу все города оптом, используя кнопку Обновить всё на вкладке Данные (Data — Refresh All).

Ссылки по теме

• Что такое макросы, как их создавать и использовать
• Сохранение листов книги как отдельных файлов
• Сборка данных со всех листов книги в одну таблицу

Введение

Предположим, у нас есть рабочий лист с большим количеством данных, и нам нужно разделить данные на отдельные книги Excel на основе столбца «Категория». Решить данную проблему возможно ручным способом, применяя инструмент фильтрации данных. Однако повторное копирование данных потребует терпения.

Как быстро разделить таблицу Excel на отдельные книги макросом. Пошаговый алгоритм

• Сочетанием клавиш Alt+F11 открываем окно Visual Basic
• Создаем новый модуль Insert -> Module
• Вставляем код

Sub Разделить_столбец_по_книгам()
Const column = 2 'номер столбца, по которому будет происходить разделение.'
Const head = True
Set wbAct = ActiveWorkbook

Set dic = CreateObject("Scripting.Dictionary")

lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).column

arr = Range("A1", Cells(lr, lc)).Value

If head Then fr = 2 Else fr = 1

For i = fr To UBound(arr)
    If Trim(arr(i, column)) <> "" Then dic.Item(arr(i, column)) = dic.Item(arr(i, column)) & "|" & i
Next

iPath = wbAct.Path & Application.PathSeparator & "Result" & Application.PathSeparator
'Result - название папки с результатами'
If Dir(iPath, vbDirectory) = "" Then MkDir iPath

arrDic = dic.keys
Set Rng = Nothing
Application.DisplayAlerts = False
For i = 0 To UBound(arrDic)
rrs = Split(Mid(dic.Item(arrDic(i)), 2), "|")
    If head Then Set Rng = Rows(1)
    For Each rr In rrs
        If Not Rng Is Nothing Then Set Rng = Union(Rows(rr), Rng) Else Set Rng = Rows(rr)
    Next
    Set wb = Workbooks.Add(1)
    Set sh = wb.Sheets(1)
    Rng.Copy
    sh.[A1].PasteSpecial xlPasteColumnWidths
    sh.[A1].PasteSpecial xlPasteAll
    Set Rng = Nothing
    wb.SaveAs iPath & Replace_symbols(arrDic(i)) & ".xlsx", xlOpenXMLWorkbook
    wb.Close False
Next
Application.DisplayAlerts = True
End Sub
'Замена запрещённых символов в имени файла или папки'
Function Replace_symbols(ByVal txt As String) As String
    St$ = "\/~!@#$%^&*=|`'"""
    For i% = 1 To Len(St$)
        txt = Replace(txt, Mid(St$, i, 1), "_")
    Next
    Replace_symbols = txt
End Function

• На второй строке кода, цифру 2 замените на номер столбца, в котором содержится критерий для разбиения
• Сохраните код Ctrl+S
• Сохраните файл Excel, как книгу с поддержкой макросов xlsm
• Выполните макрос Alt+F8

Папка с новыми файлами будет лежать по тому же пути, что и файл, в котором вы запускали макрос

Заключение

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

У нас Вы можете заказать выполнение задач по MS Excel и Google таблицам

А также, пройти бесплатные онлайн курсы по MS Excel с заданиями

Text to Columns feature can help you split text strings in Excel. Using VBA, you can make this process even faster. In this guide, we’re going to show you how to split text with VBA in Excel.

Download Workbook

Data

In this example, we have rows of data containing data separated by “|” characters. Each part represents an individual column.

Splitting text with VBA

If you are unfamiliar with VBA (Visual Basic for Applications), you can check out our beginner’s guide here: How to create a macro in Excel

Split Method

VBA has a function named Split which can return an array of sub-strings from a given string. The function parameters are the string to be split and a delimiter character which separates the sub-strings. In our example, the original strings are in cells in B6:B12 and there are “|” characters between the sub-strings.

The following code loops through each cell in the selected range, uses the Split function to create array of substrings, and uses another loop to distribute the sub-strings into adjacent cells in the same row.

Sub SplitText()
  Dim StringArray() As String, Cell As Range, i As Integer
  For Each Cell In Selection ‘To work on a static range replace Selection via Range object, e.g., Range(“B6:B12”)
    StringArray = Split(Cell, «|») ‘Change the delimiter with a character suits your data
    For i = 0 To UBound(StringArray)
      Cell.Offset(, i + 1) = StringArray(i)
      Cell.Offset(, i + 1).EntireColumn.AutoFit ‘This is for column width and optional.
    Next i
  Next
End Sub

You can copy paste the code above to use it in your workbook. However, make sure to update it depending on your data (i.e. change the delimiter or remove the Cell.Offset(, i + 1).EntireColumn.AutoFit if you do not want to change the column widths).

Text to Columns Method to split text with VBA

In VBA, you can call the Text to Columns feature of Excel. The method can be called for a range. Since we want to split cells by a delimiter, the argument DataType should be xlDelimited. The Destination argument determines the top-left cell for the split substrings. Each delimiter type has its own argument. Since the “|” character is not supported natively, our sample code sets Other as True and OtherChar as “|”.

Sub VBATextToColumns_Other()
  Dim MyRange As Range
  Set MyRange = Selection ‘To work on a static range replace Selection via Range object, e.g., Range(«B6:B12»)
  MyRange.TextToColumns Destination:=MyRange(1, 1).Offset(, 1), DataType:=xlDelimited, Other:=True, OtherChar:=»|»
End Sub

Text to Columns Method with multiple delimiters

Text to Columns method allows using multiple built-in delimiters at once. These are Tab, Semicolon, Comma and Space. Set any corresponding argument to True to enable the delimiter. The argument names are same with the character.

The following code can split the sample text by semicolon, comma, and space characters.

Sub VBATextToColumns_Multiple()
  Dim MyRange As Range
  Set MyRange = Selection ‘To work on a static range replace Selection via Range object, e.g., Range(«B6:B12»)
  MyRange.TextToColumns _
  Destination:=MyRange(1, 1).Offset(, 1), _
  TextQualifier:=xlTextQualifierDoubleQuote, _
  DataType:=xlDelimited, _
  SemiColon:=True, _
  Comma:=True, _
  Space:=True
End Sub

Ооооо!)) Оооооо!)))
pashulka, Вы мой герой!)
Сегодня целый день работала с Вашим первым макросом)

Момент, когда я его запустила, мммм! Минута и 15 секунд на 12 тысяч строк! Шикааааарно!))
Я так вдохновилась, что нарисовала себе ещё один файлик-болванку, который бы брал данные из открытого файла (из примерно 200, которые сформировались) и делал то, что я делала обычно вручную (убирал дубликаты по столбцу, вставлял в таблицу, выделял строки на удаление) . Работала с ним сегодня цельный день, сделала 35 файлов даже с учётом двух макросов…

Если раньше по моим подсчётам у меня должно было уйти 14 дней (четырнадцааааать) , то сейчас я рассчитываю ещё примерно на 12 часов)
Боюсь представить, сколько будет, если использовать то, что Вы ещё написали!)) Пойду проверю!))
Спасибо-спасибо-спасибооооо!))

Функция предназначена для разбивки текстового файла на несколько файлов меньшего размера — в каждом из которых будет не более заданнного количества строк

Разделитель строк (обычно это перевод строки — константа vbNewLine) задаётся в качестве параметра функции Delimiter$

Создаваемые файлы получают имена вида filename(1).txt, filename(2).txt и т.д.

Если задан параметр функции DeleteSourceFile равным TRUE, — то исходный файл удаляется после разделения

Функция возвращает коллекцию, содержащую пути к сформированным файлам

В начало каждого создаваемого файла дописывается строка заголовка — первая строка из исходного файла

Пример использования функции SplitTextFile:

Sub ПримерИспользованияФункции_SplitTextFile()
    ИмяРазбиваемогоФайла$ = "C:test2011 04 17  12-32-30.csv"
    МаксимальноеКоличествоСтрокВфайле& = 3
 
    Dim СписокИмёнФайлов As Collection
    Set СписокИмёнФайлов = SplitTextFile(ИмяРазбиваемогоФайла$, МаксимальноеКоличествоСтрокВфайле&, vbNewLine, False)
 
    For Each Файл In СписокИмёнФайлов
        Debug.Print "Создан файл: " & Файл
    Next
End Sub

Результат работы примера (из окна Immediate редактора VBA)

Создан файл: C:test2011 04 17 12-32-30(1).csv
Создан файл: C:test2011 04 17 12-32-30(2).csv
Создан файл: C:test2011 04 17 12-32-30(3).csv

Код функции SplitTextFile:

Function SplitTextFile(ByVal filename$, ByVal MaxRowsCount&, ByVal Delimiter$, _
                       Optional ByVal DeleteSourceFile As Boolean = True) As Collection
    ' функция предназначена для разбивки текстового файла filename$ на несколько файлов
    ' меньшего размера - в каждом из которых будет не более MaxRowsCount& строк
    ' Разделение строк выполняется с использованием разделителя Delimiter$
    ' Создаваемые файлы получают имена вида filename(1).txt, filename(2).txt и т.д.
    ' Если DeleteSourceFile = TRUE, - то исходный файл удаляется после разбивки
    ' Возвращает коллекцию имён созданных файлов

    ext$ = "." & Split(filename$, ".")(UBound(Split(filename$, ".")))
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.OpenTextFile(filename, 1, True): txt = ts.ReadAll: ts.Close
 
    HeaderRow$ = Split(txt, Delimiter$, 2)(0) & Delimiter$    ' берем первую строку из файла как заголовок
    txt = Split(txt, Delimiter$, 2)(1)    ' остаток текста - без строки заголовка

    ' удаляем разделители строк в конце текстовой строки (если таковые присутствуют)
    While txt Like "*" & Delimiter$: txt = Left(txt, Len(txt) - Len(Delimiter$)): Wend
 
    ' RowsCount = UBound(Split(txt, Delimiter$)) + 1    ' количество текстовых строк в файле
    FileIndex& = 1    ' индекс очередного создаваемого файла

    arr = Split(txt, Delimiter$): rc = 0: Set SplitTextFile = New Collection
    For i = LBound(arr) To UBound(arr)
        rc = rc + 1
        NewTXT$ = NewTXT$ & arr(i) & Delimiter$
        If rc >= MaxRowsCount& Or i = UBound(arr) Then    ' набрали достаточно строк для записи в файл
            NewFilename$ = Mid(filename$, 1, Len(filename$) - Len(ext$)) & "(" & FileIndex & ")" & ext$
            Set ts = fso.CreateTextFile(NewFilename$, True)
            ts.Write HeaderRow$ & NewTXT$: ts.Close
            SplitTextFile.Add NewFilename$
            FileIndex& = FileIndex& + 1
            rc = 0: NewTXT$ = ""
        End If
    Next i
    Set ts = Nothing: Set fso = Nothing
    If DeleteSourceFile Then Kill filename$    ' удаляем исходный файл, если DeleteSourceFile = TRUE
End Function

Предположим, у вас есть рабочий лист с огромными строками данных, и теперь вам нужно разбить данные на несколько рабочих листов на основе Имя и фамилия столбец (см. следующий снимок экрана), а имена вводятся случайным образом. Может быть, вы можете сначала отсортировать их, а затем скопировать и вставить их один за другим в другие новые рабочие листы. Но для повторного копирования и вставки потребуется ваше терпение. Сегодня я расскажу о некоторых быстрых приемах решения этой задачи.

Разделить данные на несколько листов на основе столбца с кодом VBA

Разделить данные на несколько рабочих листов на основе столбца с Kutools for Excel

Разделить данные на несколько листов на основе столбца с кодом VBA

Если вы хотите быстро и автоматически разделить данные на основе значения столбца, следующий код VBA — хороший выбор. Пожалуйста, сделайте так:

1. Удерживайте ALT + F11 , чтобы открыть Microsoft Visual Basic для приложений окно.

2. Нажмите Вставить > Модулии вставьте следующий код в окно модуля.

Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
Dim xWS As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
xWS.Name = myarr(i) & ""
Else
xWS.Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
xWS.Paste Destination:=xWS.Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub

3, Затем нажмите F5 нажмите клавишу для запуска кода, и появится окно подсказки, напоминающее вам о выборе строки заголовка, см. снимок экрана:

4. А затем нажмите OK и во втором поле запроса выберите данные столбца, которые вы хотите разделить на основе, см. снимок экрана:

5, Затем нажмите OK, и все данные на активном листе разбиваются на несколько листов по значению столбца. И разделенные листы названы с именами разделенных ячеек. Смотрите скриншот:

Внимание: Разделенные листы помещаются в конец книги, где находится главный рабочий лист.

Разделить данные на несколько рабочих листов на основе столбца с Kutools for Excel

Примечание:Чтобы применить это Разделить данные, во-первых, вы должны скачать Kutools for Excel, а затем быстро и легко примените эту функцию.

После установки Kutools for Excel, пожалуйста, сделайте так:

1. Выберите диапазон данных, которые вы хотите разделить.

2. Нажмите Кутулс Плюс > Рабочий лист > Разделить данные, см. снимок экрана:

3. В Разделить данные на несколько листов диалоговое окно, вам необходимо:

1). Выбрать Конкретный столбец вариант в Сплит на основе раздел и выберите значение столбца, по которому вы хотите разделить данные, в раскрывающемся списке. (Если у ваших данных есть заголовки, и вы хотите вставить их в каждый новый разделенный лист, проверьте У моих данных есть заголовки опция).

2). Затем вы можете указать имена разделенных листов под Имя нового листа раздел, укажите правила имен рабочих листов из Правила раскрывающийся список, вы можете добавить Префикс or Суффикс также для имен листов.

3). Щелкните значок OK кнопка. Смотрите скриншот:

4. Теперь данные разделены на несколько листов в новой книге.

Нажмите, чтобы скачать Kutools for Excel и бесплатная пробная версия прямо сейчас!

Разделить данные на несколько рабочих листов на основе столбца с Kutools for Excel

Kutools for Excel включает более 300 удобных инструментов Excel. Бесплатная пробная версия без ограничений в течение 30 дней. Загрузите бесплатную пробную версию прямо сейчас!

Связанная статья:

Как разбить данные на несколько листов по количеству строк?