Разделете Excel листа на множество файлове въз основа на колона с помощта на VBA

Имате ли големи данни в Excel лист и трябва да разпределите този лист в няколко листа, въз основа на някои данни в колона? Това е много основна задача, но отнема много време.

Аз например разполагам с тези данни. Тези данни имат колона с име Дата, писател и Заглавие. Колоната Writer има име на писател със съответно заглавие. Искам да получа данните за всеки писател в отделни листове.

За да направя това ръчно, трябва да направя следното:

Филтрирайте едно име
Копирайте филтрираните данни
Добавете лист
Поставете данните
Преименувайте листа
Повторете всички горепосочени 5 стъпки за всяка.

В този пример имам само три имена. Представете си, ако имате 100 имена. Как бихте разделили данните в различни листове? Ще отнеме много време и ще изтощи и вас.
За да автоматизирате горния процес на разделяне на лист на няколко листа, следвайте тези стъпки.

Натиснете Alt+F11. Това ще отвори VB Editor за Excel
Добавяне на нов модул
Копирай по -долу кода в модула.

 Sub SplitIntoSheets () С Application .ScreenUpdating = False .DisplayAlerts = False End С ThisWorkbook.Activate Sheet 1. Активирайте „изчистващ филтър, ако има такъв On Error Resume Next Sheet1.ShowAllData On Error GoTo 0 Dim lsrClm As Long Dim lstRow As Long 'преброяване на последния използван ред lstRow = клетки (Rows.Count, 1) .End (xlUp) .Row Dim Uniques As Range Dim clm As String, clmNo As Long On Error GoTo handler clm = Application.InputBox ("От коя колона искате да създавате файлове" & vbCrLf & "Напр. A, B, C, AB, ZA и т.н. ") clmNo = Диапазон (clm &" 1 "). Набор колони uniques = Диапазон (clm &" 2: "& clm & lstRow) 'Извикване за премахване на дубликати, за да получите набор от уникални имена uniques = RemoveDuplicates (uniques) Извикайте CreateSheets (uniques, clmNo) С Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With Sheet1.Активирайте MsgBox "Добре направено!" Излезте от манипулатора Sub Data.ShowAllData: С Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With End Sub Функция RemoveDuplicates (уникални като диапазон) като диапазон ThisWorkbook.Activate Sheets.Add On Error Resume Next ActiveSheet.Name = "uniques" Sheets ("uniques"). Activate On Error GoTo 0 uniques.Copy Cells (2, 1). Активирайте ActiveCell.PasteSpecial xlPasteValues Range ("A1") .Value = "uniques" Dim lstRow As Long lstRow = Cells (Rows.Count, 1) .End (xlUp) .Row Range ("A2: A" & lstRow). Изберете ActiveSheet.Range (Selection.Address). : = 1, Заглавка: = xlNo lstRow = Cells (Rows.Count, 1) .End (xlUp) .Row Set RemoveDuplicates = Range ("A2: A" & lstRow) Крайна функция Sub CreateSheets (уникални като диапазон, clmNo толкова дълги) Dim lstClm As Long Dim lstRow As Long For each unique In uniques Sheet 1. Активирайте lstRow = Cells (Rows.Count, 1) .End (xlUp) .Row lstClm = Cells (1, Columns.Count) .End (xlToLeft) .Column Dim dataSet As Range Set dataSet = Range (Клетки (1, 1), Клетки (lstRow, lstClm)) xlUp) .Row lstClm = Клетки (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 Следващ уникален край Sub

Когато тичаш SplitIntoSheets () процедурата, листът ще бъде разделен на няколко листа, въз основа на дадената колона. Можете да добавите бутон към листа и да му присвоите този макрос.

Как работи
Горният код има две процедури и една функция. Две процедури са SplitIntoSheets (), CreateSheets (уникални като диапазон, clmNo толкова дълги) и една функция е RemoveDuplicates (уникални като диапазон) като диапазон.

Първата процедура е SplitIntoSheets (). Това е основната процедура. Тази процедура задава променливите и RemoveDuplicates за да получите уникални имена от дадена колона и след това ги предава на CreateSheets за създаване на листове.

RemoveDuplicates приема един аргумент, който е диапазон, който съдържа име. Премахва дубликати от тях и връща обект на диапазон, който съдържа уникални имена.

Сега CreateSheets е наречен. Необходими са два аргумента. Първо уникалните имена и второ колоната не. от които ние ще попълним данните. Сега CreateSheets взема всяко име от уникални и филтрира дадения номер на колоната по всяко име. Копира филтрираните данни, добавя лист и поставя данните там. И вашите данни се разделят на различни листове за секунди.

Можете да изтеглите файла тук.
Разделяне на листове

Как да използвате файла:

- Копирайте данните си на Sheet1. Уверете се, че започва от A1.

- Щракнете върху бутона Разделяне на листове
- Въведете буквата на колоната, от която искате да се разделите. Щракнете върху OK.

- Ще видите подкана като тази. Вашият лист е разделен.

Надявам се статията за разделянето на данни на отделни листове да ви е била полезна. Ако имате някакви съмнения относно това или за някоя друга функция на Excel, не се колебайте да го попитате в секцията за коментари по -долу.