Εάν χειρίζεστε πολλά φύλλα ταυτόχρονα και θέλετε να αντιγράψετε δεδομένα από κάθε φύλλο σε ένα κύριο φύλλο εργασίας, τότε θα πρέπει να διαβάσετε αυτό το άρθρο. Θα χρησιμοποιήσουμε την τρέχουσα ιδιότητα περιοχής του κώδικα VBA για να συγκεντρώσουμε δεδομένα από όλα τα φύλλα εργασίας σε ένα μόνο φύλλο. Αυτή η ιδιότητα είναι χρήσιμη για πολλές λειτουργίες που επεκτείνουν αυτόματα την επιλογή ώστε να περιλαμβάνει ολόκληρη την τρέχουσα περιοχή, όπως η μέθοδος αυτόματης μορφοποίησης. Αυτή η ιδιότητα δεν μπορεί να χρησιμοποιηθεί σε προστατευμένο φύλλο εργασίας.
Η συνθήκη είναι: κάθε φύλλο πρέπει να περιέχει παρόμοια μορφή, δηλαδή τον ίδιο αριθμό στηλών. χρησιμοποιώντας την ίδια μορφή μπορούμε να έχουμε ακριβή συγχώνευση δεδομένων.
Παρακαλώ σημειώστε: αυτό το άρθρο θα δείξει χρησιμοποιώντας τον κωδικό VBA. εάν για οποιονδήποτε λόγο ο αριθμός των στηλών διαφέρει σε ένα από τα φύλλα, τότε ολόκληρα τα συγχωνευμένα δεδομένα δεν θα δώσουν ακριβή εικόνα. Συνιστάται ιδιαίτερα η χρήση ίδιου αριθμού στηλών. Ο κώδικας VBA θα προσθέσει ένα νέο φύλλο στο βιβλίο εργασίας και στη συνέχεια θα αντιγράψει και επικολλήσει τα δεδομένα μετά από κάθε φύλλο χωρίς αντικατάσταση.
Ας πάρουμε ένα παράδειγμα 3 φύλλων, συγκεκριμένα Jan, Feb & Mar. Ακολουθεί το στιγμιότυπο αυτών των φύλλων:
Για να συνδυάσουμε δεδομένα από όλα τα φύλλα σε ένα φύλλο, πρέπει να ακολουθήσουμε τα παρακάτω βήματα για να ξεκινήσουμε τον επεξεργαστή VB:
- Κάντε κλικ στην καρτέλα Προγραμματιστής
- Από την ομάδα κώδικα επιλέξτε Visual Basic
- Αντιγράψτε τον παρακάτω κώδικα στην τυπική μονάδα
Sub CopyCurrentRegion () Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long If SheetExists ("Master") = True then MsgBox "The sheet sheet ήδη υπάρχει" Exit Sub End If Application.ScreenUpdating = False Set DestSh = Worksheets.Add DestSh .Name = "Master" For Every sh In ThisWorkbook.Workshef If sh.Name DestSh.Name Then If sh.UsedRange.Count> 1 Then Last = LastRow (DestSh) sh.Range ("A1"). CurrentRegion.Copy DestSh Κελιά (Τελευταία + 1, 1) Τέλος Αν Τέλος Αν Επόμενη Εφαρμογή.ScreenUpdating = True End Sub Sub CopyCurrentRegionValues () Dim sh As Works Master υπάρχει ήδη "Exit Sub End If Application.ScreenUpdating = False Set DestSh = Worksheets.Add DestSh.Name =" Master "For every sh In ThisWorkbook.Worksheets If sh.Name DestSh.Name Then If sh.UsedRange.Count> 1 Στη συνέχεια Last = LastRow (DestSh) With sh.Range ("A1"). CurrentRegion DestSh.Cells (Last + 1, 1). Resesize (.Rows.Count, _ .Columns.Count) .Value = .Αξία Τερματισμός με Τέλος Αν Τέλος Εάν Επόμενη Εφαρμογή.ScreenUpdating = True End Sub Function LastRow (sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find (What: = "*", _ After: = sh.Range ("A1"), _ Lookat: = xlPart, _ LookIn: = xlFormulas, _ SearchOrder: = xlByRows, _ SearchDirection: = xlPrevious, _ MatchCase: = False). Row On Error GoTo 0 End Function Function Lastcol (sh As Worksheet ) On Error Resume Next Lastcol = sh.Cells.Find (What: = "*", _ After: = sh.Range ("A1"), _ Lookat: = xlPart, _ LookIn: = xlFormulas, _ SearchOrder: = xlByColumns , _ _ SearchDirection: = xlPrevenue, _ MatchCase: = False). Colon On Error GoTo 0 End Function Function SheetExists (SName As String, _ Optional ByVal WB As Workbook) As Boolean On Error Resume Next If WB is Nothing then Set WB = ThisWorkbook SheetExists = CBool (Len (Φύλλα (SName). Όνομα)) Λειτουργία λήξης
Η μακροεντολή CopyCurrentRegion θα καλέσει τη λειτουργία "SheetExists" και θα ελέγξει εάν υπάρχει όνομα φύλλου εργασίας με "Master". εάν βρεθεί, τότε δεν θα κάνει τίποτα, αλλιώς θα εισαγάγει νέο φύλλο εργασίας στο ενεργό βιβλίο και θα το μετονομάσει σε "Master" και στη συνέχεια θα αντιγράψει δεδομένα από όλα τα φύλλα.
Ακολουθούν τα στιγμιότυπα των συγκεντρωτικών δεδομένων:
Σημείωση: Το δείγμα βιβλίου εργασίας περιέχει κύριο φύλλο εργασίας. προτείνεται να διαγράψετε το κύριο φύλλο εργασίας και στη συνέχεια να εκτελέσετε τη μακροεντολή για να δείτε τον κώδικα VBA να λειτουργεί.
Συμπέρασμα:Τώρα έχουμε τον κωδικό που μπορούμε να χρησιμοποιήσουμε για τη μεταφορά δεδομένων από κάθε φύλλο εργασίας σε ένα φύλλο.
Αν σας άρεσαν τα ιστολόγια μας, μοιραστείτε το με τους φίλους σας στο Facebook. Επίσης, μπορείτε να μας ακολουθήσετε στο Twitter και το Facebook.
Θα θέλαμε πολύ να σας ακούσουμε, ενημερώστε μας πώς μπορούμε να βελτιώσουμε, να συμπληρώσουμε ή να καινοτομήσουμε το έργο μας και να το κάνουμε καλύτερο για εσάς. Γράψτε μας στον ιστότοπο email