Διαχωρίστε το φύλλο Excel σε πολλά αρχεία με βάση τη στήλη χρησιμοποιώντας VBA

Έχετε μεγάλα δεδομένα για το φύλλο excel και πρέπει να το διανείμετε σε πολλά φύλλα, με βάση ορισμένα δεδομένα σε μια στήλη; Αυτό το πολύ βασικό έργο αλλά χρονοβόρο.

Για παράδειγμα, έχω αυτά τα δεδομένα. Αυτά τα δεδομένα έχουν μια στήλη με όνομα Ημερομηνία, Συγγραφέας και ΤίτλοςΤο Η στήλη Συγγραφέας έχει όνομα συγγραφέα αντίστοιχου τίτλου. Θέλω να λάβω τα δεδομένα κάθε συγγραφέα σε ξεχωριστά φύλλα.

Για να το κάνω αυτό χειροκίνητα, πρέπει να κάνω τα εξής:

Φιλτράρετε ένα όνομα
Αντιγράψτε τα φιλτραρισμένα δεδομένα
Προσθέστε ένα φύλλο
Επικολλήστε τα δεδομένα
Μετονομάστε το φύλλο
Επαναλάβετε όλα τα παραπάνω 5 βήματα για το καθένα.

Σε αυτό το παράδειγμα, έχω μόνο τρία ονόματα. Φανταστείτε αν έχετε 100s ονόματα. Πώς θα χωρίζατε τα δεδομένα σε διαφορετικά φύλλα; Θα πάρει πολύ χρόνο και θα σας αδειάσει και εσάς.
Για να αυτοματοποιήσετε τη διαδικασία διαίρεσης του φύλλου σε πολλά φύλλα, ακολουθήστε αυτά τα βήματα.

Πατήστε Alt+F11. Αυτό θα ανοίξει το VB Editor για Excel
Προσθήκη νέας μονάδας
Αντιγράψτε τον παρακάτω κώδικα στην ενότητα.

 Sub SplitIntoSheets () Με Εφαρμογή .ScreenUpdating = Λάθος .DisplayAlerts = Λάθος Λήξη Με ThisWorkbook.Activate Sheet1.Ενεργοποιήστε το φίλτρο εκκαθάρισης εάν υπάρχει On Error Resume Next Sheet1.ShowAllData On Error GoTo 0 Dim lsrClm As Long Dim lstRow As Long 'counting last used row 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 = Range (clm &" 1 "). Column Set uniques = Range (clm &" 2: "& clm & lstRow) 'Calling Remove Duplicates to Get Unique Names Set uniques = RemoveDuplicates (uniques) Call 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 χειριστής: Με εφαρμογή .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Lacculation = 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). 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 (μοναδικά ως εύρος, clm Όχι όσο) Dim lstClm As Long Dim lstRow Όσο για κάθε μοναδικό σε μοναδικό φύλλο 1. Ενεργοποιήστε lstRow = Κελιά (Rows.Count, 1). End (xlUp). Row lstClm = Cells (1, Columns.Count). End (xlToLeft). 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). Τέλος ( xlUp). Row lstClm = Cells (1, Columns.Count). End (xlToLeft). Debug στήλης. Εκτύπωση lstRow; lstClm Set dataSet = Range (Cells (1, 1), Cells (lstRow, lstClm)) dataSet.Copy Sheets.Add ActiveSheet.Name = unique.Value2 ActiveCell.PasteSpecial xlPasteAll Next next unique End Sub

Όταν θα τρέξεις SplitIntoSheets () διαδικασία, το φύλλο θα χωριστεί σε πολλά φύλλα, με βάση τη δεδομένη στήλη. Μπορείτε να προσθέσετε κουμπί στο φύλλο και να του εκχωρήσετε αυτήν τη μακροεντολή.

Πως δουλεύει
Ο παραπάνω κώδικας έχει δύο διαδικασίες και μία λειτουργία. Δύο διαδικασίες είναι SplitIntoSheets (), CreateSheets (uniques As Range, clmNo As Long) και μια λειτουργία είναι RemoveDuplicates (uniques As Range) As Range.

Η πρώτη διαδικασία είναι SplitIntoSheets ()Το Αυτή είναι η κύρια διαδικασία. Αυτή η διαδικασία ορίζει τις μεταβλητές και RemoveDuplicates για να λάβετε μοναδικά ονόματα από μια δεδομένη στήλη και στη συνέχεια να τα περάσετε σε CreateSheets για τη δημιουργία φύλλων.

RemoveDuplicates παίρνει ένα όρισμα που είναι εύρος που περιέχει όνομα. Αφαιρεί τα διπλότυπα από αυτά και επιστρέφει ένα αντικείμενο περιοχής που περιέχει μοναδικά ονόματα.

Τώρα CreateSheets λέγεται. Χρειάζονται δύο επιχειρήματα. Πρώτα τα μοναδικά ονόματα και δεύτερα η στήλη αρ. από το οποίο θα προσαρμόσουμε τα δεδομένα. Τώρα CreateSheets παίρνει κάθε όνομα από μοναδικά και φιλτράρει τον δεδομένο αριθμό στήλης με κάθε όνομα. Αντιγράφει τα φιλτραρισμένα δεδομένα, προσθέτει ένα φύλλο και επικολλά τα δεδομένα εκεί. Και τα δεδομένα σας χωρίζονται σε διαφορετικό φύλλο σε δευτερόλεπτα.

Μπορείτε να κατεβάσετε το αρχείο εδώ.
Διαχωρισμός σε φύλλα

Πώς να χρησιμοποιήσετε το αρχείο:

- Αντιγράψτε τα δεδομένα σας στο Sheet1. Βεβαιωθείτε ότι ξεκινά από το Α1.

- Κάντε κλικ στο κουμπί Διαίρεση σε φύλλα
- Εισαγάγετε το γράμμα της στήλης από το οποίο θέλετε να χωρίσετε. Κάντε κλικ στο κουμπί Ok.

- Θα δείτε μια παρόμοια προτροπή. Το φύλλο σας είναι χωρισμένο.

Ελπίζω ότι το άρθρο σχετικά με τη διαίρεση δεδομένων σε ξεχωριστά φύλλα ήταν χρήσιμο για εσάς. Εάν έχετε αμφιβολίες για αυτό ή για οποιοδήποτε άλλο χαρακτηριστικό του excel, μη διστάσετε να το ρωτήσετε στην παρακάτω ενότητα σχολίων.