Note: The other languages of the website are Google-translated. Back to English

Πώς να κάνετε βρόχο μέσω αρχείων σε έναν κατάλογο και να αντιγράψετε δεδομένα σε ένα κύριο φύλλο στο Excel;

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

Περάστε τα αρχεία σε έναν κατάλογο και αντιγράψτε τα δεδομένα σε ένα κύριο φύλλο με τον κώδικα VBA


Περάστε τα αρχεία σε έναν κατάλογο και αντιγράψτε τα δεδομένα σε ένα κύριο φύλλο με τον κώδικα VBA

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

1. Στο βιβλίο εργασίας θα δημιουργήσετε ένα κύριο φύλλο εργασίας, πατήστε το άλλος + F11 για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

2. Στο Microsoft Visual Basic για εφαρμογές παράθυρο, κάντε κλικ στην επιλογή Κύριο θέμα > Μονάδα μέτρησης. Στη συνέχεια, αντιγράψτε κάτω από τον κώδικα VBA στο παράθυρο κώδικα.

Κωδικός VBA: μεταβείτε σε αρχεία σε ένα φάκελο και αντιγράψτε δεδομένα σε ένα κύριο φύλλο

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Note:

1). Στον κώδικα, «Α1: Δ4"Και"Sheet1Σημαίνει ότι τα δεδομένα στην περιοχή A1: D4 όλων των φύλλων 1 θα αντιγραφούν στο κύριο φύλλο Και "Νέο φύλλο"Είναι το όνομα του νέου φύλλου που δημιουργήθηκε.
2). Τα αρχεία Excel στον συγκεκριμένο φάκελο δεν πρέπει να ανοίγουν.

3. Πάτα το F5 κλειδί για την εκτέλεση του κώδικα.

4. Στο άνοιγμα Αναζήτηση παρακαλώ, επιλέξτε το φάκελο που περιέχει τα αρχεία στα οποία θα περάσετε και, στη συνέχεια, κάντε κλικ στο OK κουμπί. Δείτε το στιγμιότυπο οθόνης:

Στη συνέχεια, δημιουργείται ένα κύριο φύλλο εργασίας με το όνομα "Νέο φύλλο" στο τέλος του τρέχοντος βιβλίου εργασίας. Και τα δεδομένα στο εύρος A1: D4 όλων των φύλλων 1 στον επιλεγμένο φάκελο παρατίθενται στο φύλλο εργασίας.


Σχετικά άρθρα:


Τα καλύτερα εργαλεία παραγωγικότητας του Office

Το Kutools για Excel λύνει τα περισσότερα από τα προβλήματά σας και αυξάνει την παραγωγικότητά σας κατά 80%

  • Επαναχρησιμοποίηση: Εισαγάγετε γρήγορα σύνθετοι τύποι, γραφήματα και οτιδήποτε έχετε χρησιμοποιήσει στο παρελθόν. Κρυπτογράφηση κυττάρων με κωδικό πρόσβασης Δημιουργία λίστας αλληλογραφίας και στείλτε email ...
  • Super Formula Bar (επεξεργαστείτε εύκολα πολλές γραμμές κειμένου και τύπου). Διάταξη ανάγνωσης (εύκολη ανάγνωση και επεξεργασία μεγάλου αριθμού κελιών). Επικόλληση σε φιλτραρισμένο εύρος...
  • Συγχώνευση κελιών / σειρών / στηλών χωρίς απώλεια δεδομένων · Περιεχόμενο διαχωρισμού κελιών Συνδυάστε διπλές σειρές / στήλες... Αποτροπή διπλών κυττάρων; Συγκρίνετε τα εύρη...
  • Επιλέξτε Διπλότυπο ή Μοναδικό Σειρές; Επιλέξτε Κενές σειρές (όλα τα κελιά είναι κενά). Σούπερ εύρεση και ασαφής εύρεση σε πολλά βιβλία εργασίας. Τυχαία επιλογή ...
  • Ακριβές αντίγραφο Πολλαπλά κελιά χωρίς αλλαγή της αναφοράς τύπου. Αυτόματη δημιουργία αναφορών σε πολλαπλά φύλλα? Εισαγωγή κουκκίδων, Πλαίσια ελέγχου και άλλα ...
  • Εξαγωγή κειμένου, Προσθήκη κειμένου, Κατάργηση κατά θέση, Αφαιρέστε το διάστημα; Δημιουργία και εκτύπωση υποσύνολων σελιδοποίησης. Μετατροπή περιεχομένου και σχολίων μεταξύ κελιών...
  • Σούπερ φίλτρο (αποθηκεύστε και εφαρμόστε σχήματα φίλτρων σε άλλα φύλλα). Προηγμένη ταξινόμηση ανά μήνα / εβδομάδα / ημέρα, συχνότητα και άλλα. Ειδικό φίλτρο με έντονη, πλάγια ...
  • Συνδυάστε βιβλία εργασίας και φύλλα εργασίας; Συγχώνευση πινάκων βάσει βασικών στηλών. Διαχωρίστε τα δεδομένα σε πολλά φύλλα; Μαζική μετατροπή xls, xlsx και PDF...
  • Περισσότερα από 300 ισχυρά χαρακτηριστικά. Υποστηρίζει Office / Excel 2007-2021 και 365. Υποστηρίζει όλες τις γλώσσες. Εύκολη ανάπτυξη στην επιχείρηση ή τον οργανισμό σας. Πλήρεις δυνατότητες δωρεάν δοκιμής 30 ημερών. Εγγύηση επιστροφής χρημάτων 60 ημερών.
kte καρτέλα 201905

Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
κάτω μέρος γραφείου
Σχόλια (20)
Δεν υπάρχουν ακόμη βαθμολογίες. Γίνε ο πρώτος που θα αξιολογήσετε!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
ευχαριστω για τον κωδικο vba! Λειτουργεί τέλεια! Θα θέλατε να μάθετε ποιος είναι ο κωδικός εάν πρέπει να επικολλήσω ΩΣ ΑΞΙΑ; Thx εκ των προτέρων!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Lai Ling,
Ο παρακάτω κώδικας μπορεί να σας βοηθήσει να λύσετε το πρόβλημα. Σας ευχαριστούμε για το σχόλιό σας.

Sub Merge2MultiSheets()
Dim xRg ως εύρος
Dim xSelItem As Variant
Dim xFileDlg ως FileDialog
Dim xFileName, xSheetName, xRgStr ως συμβολοσειρά
Dim xBook, xWorkBook As Workbook
Dim xSheet ως φύλλο εργασίας
On Error Συνέχιση Επόμενη
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Φύλλο1"
xRgStr = "A1:D4"
Ορισμός xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Με xFileDlg
Αν .Εμφάνιση = -1 Τότε
xSelItem = .SelectedItems.Item(1)
Ορίστε xWorkBook = This Workbook
Ορισμός xSheet = xWorkBook.Sheets ("Νέο φύλλο")
Εάν το xSheet δεν είναι τίποτα, τότε
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "New Sheet"
Ορισμός xSheet = xWorkBook.Sheets ("Νέο φύλλο")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Εάν xFileName = "" Τότε βγείτε από το Sub
Κάντε μέχρι xFileName = ""
Ορισμός xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ορισμός xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Κλείσιμο
Βρόχος
End If
Τέλος με
Ορισμός xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, ευχαριστώ για τον κωδικό. Μπορείτε να με ενημερώσετε πώς μπορώ να συμπεριλάβω το όνομα αρχείου Excel από το οποίο αντιγράφηκε η περιοχή δεδομένων; Αυτό θα ήταν μεγάλη βοήθεια!

Σας ευχαριστώ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.

Ευχαριστώ για το σεμινάριο.

Πώς θα κάνω: Αντιγράψτε μόνο τη σειρά στο "Φύλλο1" με τιμές από τη σειρά "σύνολο" και επικολλήστε με [όνομα αρχείου] στο κύριο φύλλο εργασίας που ονομάζεται "Νέο φύλλο". Η σημείωση της γραμμής με Σύνολο μπορεί να είναι διαφορετική σε κάθε φύλλο εργασίας.

Για παράδειγμα:
Αρχείο 1: Φύλλο 1
Col1, Col2, Colx
1,2,15
Αποτέλεσμα, 10,50

Αρχείο 2: Φύλλο 1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Αποτέλεσμα, 300,500

MasterFile: "Νέο φύλλο":
αρχείο 1, 10, 50
αρχείο 2, 300, 500
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου, Λειτουργεί τέλεια. Υπάρχει τρόπος να αλλάξετε απλώς τις τιμές και όχι τον τύπο;
Ευχαριστώ!!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Trish,
Ο παρακάτω κώδικας μπορεί να σας βοηθήσει να λύσετε το πρόβλημα. Σας ευχαριστούμε για το σχόλιό σας.

Sub Merge2MultiSheets()
Dim xRg ως εύρος
Dim xSelItem As Variant
Dim xFileDlg ως FileDialog
Dim xFileName, xSheetName, xRgStr ως συμβολοσειρά
Dim xBook, xWorkBook As Workbook
Dim xSheet ως φύλλο εργασίας
On Error Συνέχιση Επόμενη
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Φύλλο1"
xRgStr = "A1:D4"
Ορισμός xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Με xFileDlg
Αν .Εμφάνιση = -1 Τότε
xSelItem = .SelectedItems.Item(1)
Ορίστε xWorkBook = This Workbook
Ορισμός xSheet = xWorkBook.Sheets ("Νέο φύλλο")
Εάν το xSheet δεν είναι τίποτα, τότε
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "New Sheet"
Ορισμός xSheet = xWorkBook.Sheets ("Νέο φύλλο")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Εάν xFileName = "" Τότε βγείτε από το Sub
Κάντε μέχρι xFileName = ""
Ορισμός xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ορισμός xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Κλείσιμο
Βρόχος
End If
Τέλος με
Ορισμός xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, εξακολουθεί να τραβάει τους τύπους, όχι τις τιμές, επομένως μου δίνει ένα σφάλμα #REF. Ξέρω ότι μπορεί να χρειαστεί κάπου ένα .PasteSpecial xlPasteValues, αλλά δεν μπορώ να καταλάβω πού. Μπορεις να βοηθησεις? Ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας Ευχαριστώ για αυτό.


Πώς μπορώ να συμπεριλάβω τον κώδικα για να πραγματοποιήσω βρόχο σε όλους τους φακέλους και τους υποφακέλους και να εκτελέσω την παραπάνω αντιγραφή;


Ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια - Αυτός ο κωδικός είναι τέλειος για αυτό που προσπαθώ να επιτύχω.

Υπάρχει τρόπος να πραγματοποιήσετε επαναφορά σε όλους τους φακέλους και τους υποφακέλους και να εκτελέσετε την αντιγραφή;


Ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια - Αυτός ο κώδικας λειτουργεί πολύ καλά για τις πρώτες 565 γραμμές για κάθε αρχείο, αλλά όλες οι γραμμές μετά επικαλύπτονται από το επόμενο αρχείο.
Υπάρχει τρόπος να το διορθώσω αυτό εκεί?
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ευχαριστούμε - πώς θα μπορούσε κανείς να αντιγράψει και να επικολλήσει (ειδικές τιμές) από κάθε φύλλο εργασίας ενός βιβλίου εργασίας σε ξεχωριστά φύλλα ενός κύριου αρχείου Master;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
πώς κάνετε τον κώδικα να αφήσετε κενό εάν το κελί είναι κενό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
για μένα, το όνομα της καρτέλας "Φύλλο1" αλλάζει για κάθε ένα από τα αρχεία μου. Για παράδειγμα, Tab1, Tab2, Tab3, Tab4...Πώς μπορώ να ρυθμίσω έναν βρόχο ώστε να τρέχει μέσα από μια λίστα στο excel και να αλλάζω συνέχεια το όνομα "Φύλλο1" μέχρι να εκτελεστεί τα πάντα;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Nick, Ο παρακάτω κώδικας VBA μπορεί να σε βοηθήσει να λύσεις το πρόβλημα. Δοκιμάστε. Sub LoopThroughFileRename()
«Ενημερώθηκε από το Extendofice 2021/12/31
Dim xRg ως εύρος
Dim xSelItem As Variant
Dim xFileDlg ως FileDialog
Dim xFileName, xSheetName, xRgStr ως συμβολοσειρά
Dim xBook, xWorkBook As Workbook
Dim xSheet ως φύλλο εργασίας
Dim xShs ως φύλλα
Dim xName As String
Dim xFNum ως ακέραιος αριθμός
On Error Συνέχιση Επόμενη
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Ορισμός xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Εμφάνιση
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Do while xFileName <> ""
Ορισμός xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ορίστε xShs = xWorkBook.Sheets
Για xFNum = 1 έως xShs.Count
Ορισμός xSheet = xShs.Item(xFNum)
xName = xSheet.Name
xName = Αντικατάσταση(xName, "Φύλλο""Tab") 'Αντικατάσταση φύλλου με καρτέλα
xSheet.Name = xName
Επόμενο
xWorkBook.Αποθήκευση
xWorkBook.Κλείσιμο
xFileName = Dir()
Βρόχος
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, θέλω έναν κωδικό για να αντιγράψω τα δεδομένα σε 6 διαφορετικά βιβλία εργασίας (σε ένα φάκελο) που περιλαμβάνει φύλλα στο ΝΕΟ ΒΙΒΛΙΟ ΕΡΓΑΣΙΑΣ. σε vba
παρακαλώ βοηθήστε με asp
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Paranusha,
Η δέσμη ενεργειών VBA στο ακόλουθο άρθρο μπορεί να συνδυάσει πολλά βιβλία εργασίας ή καθορισμένα φύλλα βιβλίων εργασίας σε ένα κύριο βιβλίο εργασίας. Ελέγξτε εάν μπορεί να βοηθήσει.
Πώς να συνδυάσετε πολλά βιβλία εργασίας σε ένα κύριο βιβλίο εργασίας στο Excel;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Olá bom dia.
Gostei muito dessde código, mas não me ajudou com os relatórios que eu preciso impreimir.
Preciso imprimir 2.400 relatório de exel que estão em pastas diferentes and não estão configuradas corretamente para impressão. Pode me enviar um códgo de VBA que αυτοματοποιήσει τα essas impressões ; Me ajudaria muito, obrigada.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Μαρία Σοάρες,
Ελέγξτε εάν ο κώδικας VBA στην ακόλουθη ανάρτηση μπορεί να βοηθήσει.
Πώς να εκτυπώσετε πολλά βιβλία εργασίας στο Excel;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Το σενάριό μου είναι παρόμοιο, εκτός από το ότι έχω πολλά φύλλα σε κάθε αρχείο, όλα με διαφορετικά ονόματα αλλά συνεπή μεταξύ των αρχείων. Υπάρχει τρόπος να κάνετε Loop αυτού του κώδικα για να αντιγράψετε τα δεδομένα μέσα στα αρχεία και να επικολλήσετε (τιμές) σε συγκεκριμένα ονόματα φύλλων στο κύριο βιβλίο εργασίας; Τα ονόματα των φύλλων στο κύριο είναι τα ίδια με τα αρχεία. Θέλω να τα περάσω. Επίσης, ο όγκος των δεδομένων σε κάθε φύλλο θα ποικίλλει, επομένως θα χρειαστεί να επιλέξω τα δεδομένα σε κάθε φύλλο χρησιμοποιώντας κάτι σαν αυτό:

Εύρος ("A1"). Επιλέξτε
Εύρος (επιλογή, επιλογή.ενός (xlDown))
Εύρος (Επιλογή, Επιλογή. Τέλος (xlToRight)). Επιλέξτε


Τα ονόματα των φύλλων αρχείων είναι Παροχή, Υπηρεσίες, Ασφάλειες, Αυτοκίνητο, Άλλα Έξοδα κ.λπ...

Ευχαριστώ εκ των προτέρων.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Andrew Shahan,
Ο παρακάτω κώδικας VBA μπορεί να λύσει το πρόβλημά σας. Μετά την εκτέλεση του κώδικα και την επιλογή ενός φακέλου, ο κώδικας θα ταιριάζει αυτόματα με το φύλλο εργασίας με το όνομα και θα επικολλήσει τα δεδομένα στο ομώνυμο φύλλο εργασίας στο κύριο βιβλίο εργασίας.
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Αφήστε τα σχόλιά σας
Δημοσίευση ως επισκέπτης
×
Αξιολογήστε αυτήν την ανάρτηση:
0   Χαρακτήρες
Προτεινόμενες τοποθεσίες

Ακολουθησε μας

Πνευματικά δικαιώματα © 2009 - www.extendoffice.com. | Ολα τα δικαιώματα διατηρούνται. Τροφοδοτείται από ExtendOffice. | Sitemap
Το Microsoft και το λογότυπο του Office είναι εμπορικά σήματα ή σήματα κατατεθέντα της Microsoft Corporation στις Ηνωμένες Πολιτείες ή / και σε άλλες χώρες.
Προστατεύεται από το Sectigo SSL