انتقال فایل ها به پوشه ای دیگر با اکسل

با سلام خدمت کاربران عزیز آی تی سواد

فرض کنید تعداد زیادی فایل در کامپیوتر داشته و لیست نام این فایل ها را نیز در worksheet اکسل وارد کرده باشید. اکنون اگر لازم باشد این فایل ها را که نام آن ها در اکسل وارد شده ، به جایی دیگر کپی یا منتقل کنید ، به نظر شما چگونه می توان این وظیفه را به سریع ترین روش و با کمک اکسل انجام داد ؟

انتقال فایل ها به پوشه ای دیگر با اکسل VBA

برای انتقال فایل ها به پوشه های دیگر بر اساس لیست نام هایشان ، کد VBA زیر به شما کمک فراوانی خواهد کرد. لطفا مراحل زیر را انجام دهید :

کلید های Alt + F11 را همزمان در اکسل نگه دارید. این کلیدهای ترکیبی پنجره Microsoft Visual Basic for Applications را باز می کند.
روی Insert > Module کلیک کنید و کد VBA زیر را در پنجره Module کپی کنید.

کد VBA : انتقال فایل ها به پوشه ای دیگر با اکسل

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("لطفا نام فایل ها را انتخاب کنید:", "آی تی سواد", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = " لطفا پوشه اول را انتخاب کنید:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = " لطفا پوشه مقصد را انتخاب کنید:"
    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

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("لطفا نام فایل ها را انتخاب کنید:", "آی تی سواد", ActiveWindow.RangeSelection.Address, , , , , 8)

If xRg Is Nothing Then Exit Sub

Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

xSFileDlg.Title = " لطفا پوشه اول را انتخاب کنید:"

If xSFileDlg.Show <> -1 Then Exit Sub

xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"

Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

xDFileDlg.Title = " لطفا پوشه مقصد را انتخاب کنید:"

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

End Sub

سپس کلید F5 را بزنید تا این کد و دستورات آن اجرا شود. مثل تصویر زیر ، کادری ظاهر خواهد شد که از ما می خواهد سلول های حاوی نام فایل ها را انتخاب کنیم.

پس انتخاب سلول ها ، بر روی OK کلیک کنید. در پنجره ظاهر شده ، پوشه ای که فایل های اصلی شما در آن قرار دارد را انتخاب کنید.

پس از انتخاب پوشه ی مبدا ، OK کنید. مشاهده خواهید کرد که پنجره ای دیگر باز می شود. ولی اینار باید پوشه مقصد خود را برای انتقال فایل ها انتخاب کنید.

باز هم روی OK کلیک کنید تا پنجره بسته شود. حالا همانطور که در تصویر زیر هم می بینید فایل های شما به پوشه ای دیگری بر اساس لیست اکسل انتقال یافت.

نکته : اگر قصد شما فقط کپی کردن فایل ها به پوشه ای دیگر است و می خواهید فایل های اصلی در همان پوشه اولیه باقی بمانند از کد VBA زیر استفاده کنید

کد VBA : برای کپی کردن فایل ها از یک پوشه به پوشه ای دیگر بر اساس لیست اکسل

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("لطفا لیست نام فایل را انتخاب کنید:", "آی تی سواد", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = "لطفا فایل مبدا را انتخاب کنید:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = "لطفا فایل مقصد را انتخاب کنید:"
    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

Sub copyfiles()