Πώς να αντιγράψετε ή να μετακινήσετε αρχεία από έναν φάκελο σε άλλο με βάση μια λίστα στο Excel;
Εάν έχετε μια λίστα ονομάτων αρχείων σε μια στήλη σε ένα φύλλο εργασίας και τα αρχεία εντοπίζονται σε ένα φάκελο στον υπολογιστή σας. Ωστόσο, τώρα, πρέπει να μετακινήσετε ή να αντιγράψετε αυτά τα αρχεία, τα ονόματα που αναφέρονται στο φύλλο εργασίας από τον αρχικό τους φάκελο σε άλλο, όπως φαίνεται στο παρακάτω στιγμιότυπο οθόνης. Πώς θα μπορούσατε να ολοκληρώσετε αυτήν την εργασία όσο πιο γρήγορα μπορείτε στο Excel;
Αντιγράψτε ή μετακινήστε αρχεία από ένα φάκελο σε άλλο με βάση μια λίστα στο Excel με κώδικα VBA
Αντιγράψτε ή μετακινήστε αρχεία από ένα φάκελο σε άλλο με βάση μια λίστα στο Excel με κώδικα VBA
Για να μετακινήσετε τα αρχεία από έναν φάκελο σε έναν άλλο με βάση μια λίστα ονομάτων αρχείων, ο ακόλουθος κώδικας VBA μπορεί να σας βοηθήσει, κάντε το εξής:
1. Κρατήστε πατημένο το Alt + F11 στο Excel και ανοίγει το Microsoft Visual Basic για εφαρμογές παράθυρο.
2. Κλίκ Κύριο θέμα > Μονάδα μέτρησηςκαι επικολλήστε τον ακόλουθο κώδικα VBA στο Παράθυρο Module.
Κωδικός VBA: Μετακίνηση αρχείων από έναν φάκελο στον άλλο με βάση μια λίστα στο Excel
Sub movefiles()
'Updateby Extendoffice
Dim xRg As Range, xCell As Range
Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
Dim xSPathStr As Variant, xDPathStr As Variant
Dim xVal As String
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = " Please select the original folder:"
If xSFileDlg.Show <> -1 Then Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = " Please select the destination folder:"
If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
For Each xCell In xRg
xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
Next
End Sub
3. Και στη συνέχεια πατήστε F5 για να εκτελέσετε αυτόν τον κώδικα και θα εμφανιστεί ένα πλαίσιο προτροπής για να σας υπενθυμίσει ότι επιλέγετε τα κελιά που περιέχουν τα ονόματα αρχείων, δείτε το στιγμιότυπο οθόνης:
4. Στη συνέχεια κάντε κλικ στο κουμπί OK κουμπί και στο αναδυόμενο παράθυρο, επιλέξτε το φάκελο που περιέχει τα αρχεία από τα οποία θέλετε να μετακινηθείτε, δείτε το στιγμιότυπο οθόνης:
5. Και στη συνέχεια κάντε κλικ στο κουμπί OK, συνεχίστε επιλέγοντας το φάκελο προορισμού στον οποίο θέλετε να εντοπίσετε τα αρχεία σε άλλο αναδυόμενο παράθυρο, δείτε το στιγμιότυπο οθόνης:
6. Τέλος, κάντε κλικ στο κουμπί OK για να κλείσετε το παράθυρο και τώρα, τα αρχεία έχουν μετακινηθεί σε έναν άλλο φάκελο που καθορίσατε με βάση τα ονόματα αρχείων στη λίστα φύλλων εργασίας, δείτε το στιγμιότυπο οθόνης:
Note: Εάν θέλετε απλώς να αντιγράψετε τα αρχεία σε άλλο φάκελο, αλλά να διατηρήσετε τα αρχικά αρχεία, εφαρμόστε τον παρακάτω κώδικα VBA:
Κωδικός VBA: Αντιγράψτε αρχεία από έναν φάκελο σε έναν άλλο με βάση μια λίστα στο Excel
Sub copyfiles()
'Updateby Extendoffice
Dim xRg As Range, xCell As Range
Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
Dim xSPathStr As Variant, xDPathStr As Variant
Dim xVal As String
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = "Please select the original folder:"
If xSFileDlg.Show <> -1 Then Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = "Please select the destination folder:"
If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
For Each xCell In xRg
xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
End If
Next
End Sub
Τα καλύτερα εργαλεία παραγωγικότητας γραφείου
Αυξήστε τις δεξιότητές σας στο Excel με τα Kutools για Excel και απολαύστε την αποτελεσματικότητα όπως ποτέ πριν. Το Kutools για Excel προσφέρει πάνω από 300 προηγμένες δυνατότητες για την ενίσχυση της παραγωγικότητας και την εξοικονόμηση χρόνου. Κάντε κλικ εδώ για να αποκτήσετε τη δυνατότητα που χρειάζεστε περισσότερο...
Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη
- Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
- Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
- Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!