Împărțiți foaia Excel în mai multe fișiere pe baza coloanei folosind VBA

Aveți date mari pe foaia Excel și trebuie să distribuiți foaia respectivă în mai multe foi, pe baza unor date dintr-o coloană? Această sarcină foarte de bază, dar consumatoare de timp.

De exemplu, am aceste date. Aceste date au o coloană numită Data, scriitor și Titlu. Coloana Writer are numele scriitorului cu titlul respectiv. Vreau să obțin datele fiecărui scriitor în foi separate.

Pentru a face acest lucru manual, trebuie să fac următoarele:

Filtrați un nume
Copiați datele filtrate
Adăugați o foaie
Lipiți datele
Redenumiți foaia
Repetați toți cei 5 pași de mai sus pentru fiecare.

În acest exemplu, am doar trei nume. Imaginați-vă dacă aveți 100 de nume. Cum ați împărți datele în diferite foi? Va dura mult timp și te va scurge și tu.
Pentru a automatiza procesul de mai sus de divizare a foii în mai multe foi, urmați acești pași.

Apăsați Alt + F11. Aceasta va deschide VB Editor pentru Excel
Adăugați un nou modul
Copiați codul de mai jos în modul.

 Sub SplitIntoSheets () With Application .ScreenUpdating = False .DisplayAlerts = False End With ThisWorkbook.Activate Sheet1.Activate 'clearing filter if any On Error Resume Next Sheet 1. ShowAllData On Error GoTo 0 Dim lsrClm As Long Dim lstRow As Long' numărând ultimul rând folosit lstRow = Celule (Rows.Count, 1) .End (xlUp) .Row Dim unique Ca Range Dim clm As String, clmNo As Long On Error GoTo handler clm = Application.InputBox ("Din care coloană doriți să creați fișiere" & vbCrLf & "Ex. A, B, C, AB, ZA etc. ") clmNo = Range (clm &" 1 "). Set de coloane unice = Range (clm &" 2: "& clm & lstRow) 'Apelare Eliminați duplicatele pentru a obține seturi de nume unice unique = RemoveDuplicates (unique) Call CreateSheets (unique, clmNo) With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With Sheet1.Activate MsgBox "Well Done!" Ieșiți din gestionarul Sub Data.ShowAllData: Cu aplicație .ScreenUpdating = Adevărat .DisplayAlerts = Adevărat. AlertBeforeOverwriting = Adevărat .Calculation = xlCalculationAutomatic End With End Sub Funcția RemoveDuplicates (unice ca Range) Ca Range ThisWorkbook.Activate Sheets.Add On Error Reîncepe Next ActiveSheet.Name = "unique" Sheets ("unique"). Activați la eroare GoTo 0 unique.Copy Cells (2, 1). Activați ActiveCell.PasteSpecial xlPasteValues Range ("A1") .Value = "unice" Dim lstRow As Long lstRow = Celule (Rows.Count, 1) .End (xlUp) .Row Range ("A2: A" & lstRow). Selectați ActiveSheet.Range (Selection.Address) .RemoveDuplicates Coloane : = 1, Header: = xlNo lstRow = Celule (Rows.Count, 1). End (xlUp) .Row Set RemoveDuplicates = Range ("A2: A" & lstRow) Funcție de sfârșit Sub CreateSheets (unice ca Range, clmNo As Long) Dim lstClm As Long Dim lstRow As Long For Each unique In unique 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

Când vei fugi SplitIntoSheets () procedura, foaia va fi împărțită în mai multe foi, pe baza coloanei date. Puteți adăuga buton pe foaie și îi puteți atribui această macro.

Cum functioneaza
Codul de mai sus are două proceduri și o funcție. Două proceduri sunt SplitIntoSheets (), CreateSheets (unice ca Range, clmNo As Long) și o funcție este RemoveDuplicates (unice ca gamă) ca gamă.

Prima procedură este SplitIntoSheets (). Aceasta este procedura principală. Această procedură stabilește variabilele și RemoveDuplicates pentru a obține nume unice dintr-o coloană dată și apoi trece aceste nume către CreateSheets pentru crearea foilor.

RemoveDuplicates ia un argument care este intervalul care conține nume. Elimină duplicatele de la ei și returnează un obiect de gamă care conține nume unice.

Acum CreateSheets se numește. Este nevoie de două argumente. În primul rând numele unice și în al doilea rând coloana nr. de la care vom extrage date. Acum CreateSheets ia fiecare nume de la unice și filtrează numărul coloanei date după fiecare nume. Copiază datele filtrate, adaugă o foaie și lipesc datele acolo. Și datele dvs. sunt împărțite în diferite foi în câteva secunde.

Puteți descărca fișierul de aici.
Împărțiți în foi

Cum se folosește fișierul:

- Copiați datele pe Sheet1. Asigurați-vă că începe de la A1.

- Faceți clic pe butonul Împărțiți în foi
- Introduceți litera coloanei din care doriți să separați. Faceți clic pe Ok.

- Veți vedea o astfel de solicitare. Foaia ta este împărțită.

Sper că articolul despre împărțirea datelor în foi separate a fost de ajutor pentru dvs. Dacă aveți îndoieli cu privire la acest lucru sau cu privire la orice altă caracteristică excel, nu ezitați să o întrebați în secțiunea de comentarii de mai jos.