Сплит Excel лист на несколько файлов, основанные на колонку с помощью VBA
У вас есть большие данные на листе Excel, и вам нужно распределить этот лист на нескольких листах на основе некоторых данных в столбце? Это очень простая задача, но требует много времени.
Например, у меня есть эти данные. У этих данных есть столбцы с именами Date, Writer и Title. В столбце Writer указано имя автора соответствующего заголовка. Я хочу собрать данные каждого писателя на отдельных листах.
Чтобы сделать это вручную, мне нужно сделать следующее:
-
Отфильтруйте одно имя. Скопируйте отфильтрованные данные. Добавьте лист. Вставьте данные. Переименуйте лист. Повторите все выше 5 шагов для каждого.
В этом примере у меня всего три имени. Представьте, что у вас есть сотни имен.
Как бы вы разбили данные на разные листы? Это займет много времени и вас тоже истощит.
Чтобы автоматизировать описанный выше процесс разделения листа на несколько листов, выполните следующие действия.
Нажмите Alt + F11. Это откроет редактор VB для Excel. Добавить новый модуль * Скопировать код ниже в модуле.
Sub SplitIntoSheets()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filter if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
'counting last used row
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim uniques As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set uniques = Range(clm & "2:" & clm & lstRow)
'Calling Remove Duplicates to Get Unique Names
Set uniques = RemoveDuplicates(uniques)
Call CreateSheets(uniques, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Sheet1.Activate
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function RemoveDuplicates(uniques As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "uniques"
Sheets("uniques").Activate
On Error GoTo 0
uniques.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "uniques"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub CreateSheets(uniques As Range, clmNo As Long)
Dim lstClm As Long
Dim lstRow As Long
For Each unique In uniques
Sheet1.Activate
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Sheets.Add
ActiveSheet.Name = unique.Value2
ActiveCell.PasteSpecial xlPasteAll
Next unique
End Sub
Когда вы запускаете процедуру SplitIntoSheets (), лист будет разделен на несколько листов в зависимости от заданного столбца. Вы можете добавить кнопку на лист и назначить ей этот макрос.
Как это работает
В приведенном выше коде есть две процедуры и одна функция. Две процедуры — это SplitIntoSheets (), CreateSheets (уникальные как диапазон, clmNo As Long) и одна функция — это RemoveDuplicates (уникальные как диапазон) как диапазон. Первая процедура — SplitIntoSheets (). Это основная процедура. Эта процедура устанавливает переменные и RemoveDuplicates для получения уникальных имен из заданного столбца, а затем передает эти имена в CreateSheets для создания листов.
RemoveDuplicates принимает один аргумент — диапазон, содержащий имя.
Удаляет из них дубликаты и возвращает объект диапазона, содержащий уникальные имена.
Теперь вызывается CreateSheets. Требуется два аргумента. Сначала уникальные имена, а затем номер столбца. из которого мы будем подбирать данные. Теперь CreateSheets берет каждое имя из уникальных пользователей и фильтрует заданный номер столбца по каждому имени. Копирует отфильтрованные данные, добавляет лист и вставляет туда данные. И ваши данные разделяются на разные листы за секунды.
Вы можете скачать файл здесь.
Разбить на листы
Как использовать файл:
-
Скопируйте свои данные на Sheet1. Убедитесь, что он начинается с A1.
Нажмите кнопку «Разбить на листы» * Введите букву столбца, из которой вы хотите разделить. Щелкните ОК.
-
Вы увидите подобное сообщение. Ваш лист разделен.
Надеюсь, статья о разделении данных на отдельные листы была для вас полезной. Если у вас есть какие-либо сомнения относительно этой или какой-либо другой функции Excel, не стесняйтесь спрашивать об этом в разделе комментариев ниже.