移动
我试图寻找答案，并尝试了各种可用的VBA。不幸的是，这些方法似乎都不起作用。
我希望实现的是:
- 将当前Excel工作簿(这是我打开的文件，下拉列表位于其中)从当前文件夹移动(不是复制)到另一个文件夹
- 工作簿不会更改名称
- 使用下拉列表 实现
例如:源文件夹= c:test，目标文件夹= c:dest和c:other。如果我选择&;dest&;在下拉列表中，文件将从c:test移动到c:dest。如果我选择" other "，它会移动到c:other(所有文件夹都是预先创建的)
下面是我到目前为止所做的，但它似乎不起作用:
If Target.Column = 5 And Target.Row = 8 Then
If Target.Value = "Dest" Then
Dim sFileNameExt As String
Dim sFilePath As String
Dim sNewPath As String
sNewPath = "c:Dest"
sFilePath = ActiveWorkbook.Path
sFileNameExt = ActiveWorkbook.Name
ActiveWorkbook.SaveAs sNewPath & sFileNameExt
Kill sFilePath & "" & sFileNameExt
ElseIf Target.Value = "Other" Then
sNewPath = "c:Other"
sFilePath = ActiveWorkbook.Path
sFileNameExt = ActiveWorkbook.Name
ActiveWorkbook.SaveAs sNewPath & sFileNameExt
Kill sFilePath & "" & sFileNameExt
End If
End If
任何帮助将非常感激(哦，如果不是很明显，我是非常新的VBA…)
移动ThisWorkbook
- 需要将代码复制到包含下拉菜单的工作表的工作表模块(例如
Sheet1)。
基本
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const sAddress As String = "E8"
Const dInitialPath As String = "C:"
Dim sCell As Range: Set sCell = Intersect(Me.Range(sAddress), Target)
If sCell Is Nothing Then Exit Sub
Dim swb As Workbook: Set swb = Me.Parent
Dim dSubFolderName As String: dSubFolderName = CStr(sCell.Value)
Select Case dSubFolderName
Case "Dest", "Other"
Dim sFilePath As String: sFilePath = swb.FullName
Dim dFilePath As String
dFilePath = dInitialPath & dSubFolderName & "" & swb.Name
If StrComp(sFilePath, dFilePath, vbTextCompare) <> 0 Then
Application.DisplayAlerts = False ' overwrite without confirmation
swb.SaveAs dFilePath
Application.DisplayAlerts = True
Kill sFilePath
MsgBox "The new filepath is '" & dFilePath & "'.", _
vbInformation
Else
MsgBox "You are trying to move this file to the same location.", _
vbExclamation
Exit Sub
End If
End Select
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
MoveThisWorkbook Target
End Sub
Sub MoveThisWorkbook(ByVal Target As Range)
Const ProcName As String = "MoveThisWorkbook"
' Define constants.
' Source
Const sAddress As String = "E8"
' Destination
Const dInitialPath As String = "C:"
Const dSubFoldersList As String = "Dest,Other"
' If you modify one of the following two (e.g. '".xlsb"'),
' you need to modify the other accordingly (e.g. 'xlExcel12').
Const dNotSavedFileExtension As String = ".xlsm"
Const dNotSavedFileFormat As Long = xlOpenXMLWorkbookMacroEnabled
' Booleans
Const InformWhenMoved As Boolean = True
Const ExploreNewLocation As Boolean = True
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = Target.Worksheet
' Reference the source (dropdown) cell ('sCell').
Dim sCell As Range: Set sCell = Intersect(sws.Range(sAddress), Target)
If sCell Is Nothing Then Exit Sub
' Return the subfolders from the list ('dSubFoldersList')
' in the destination subfolders array ('dSubFolders').
Dim dSubFolders() As String: dSubFolders = Split(dSubFoldersList, ",")
' Write the dropdown subfolder, the string representation of the value
' in the source cell, to a variable ('dSubFolder').
Dim dSubFolder As String: dSubFolder = CStr(sCell.Value)
' Check if the dropdown subfolder is not contained
' in the destination subfolders array.
If IsError(Application.Match(dSubFolder, dSubFolders, 0)) Then
MsgBox "'" & dSubFolder & "' is not contained in the following list:" _
& vbLf & Join(dSubFolders, vbLf), vbExclamation, ProcName
Exit Sub
End If
' Write the (application) path separator to a variable ('APS').
Dim APS As String: APS = Application.PathSeparator
' Append a path separator to the initial destination
' folder path, if it doesn't end with one already.
Dim diPath As String: diPath = dInitialPath
If StrComp(Right(diPath, Len(APS)), APS, vbTextCompare) <> 0 Then
diPath = diPath & APS
End If
' Validate the initial destination folder path.
If Len(Dir(diPath, vbDirectory)) = 0 Then
MsgBox "The initial destination folder location '" & diPath _
& "' doesn't exist.", vbCritical, ProcName
Exit Sub
End If
' Build the destination folder path ('dFolderPath') by appending
' the subfolder and a path separator to the initial destination
' folder path.
Dim dFolderPath As String: dFolderPath = diPath & dSubFolder & APS
' Validate the destination folder path i.e. create it
' if it doesn't exist.
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then MkDir dFolderPath
' Reference the source workbook ('swb').
Dim swb As Workbook: Set swb = sws.Parent
' Write the destination file path to a variable ('dPath').
Dim dPath As String: dPath = dFolderPath & swb.Name
' Move (or save) the file.
If Len(swb.Path) > 0 Then ' the file has previously been saved
' Write the source file path to a variable ('sPath').
Dim sPath As String: sPath = swb.FullName
' Validate the destination file path
' i.e. check if the source and destination file paths are equal.
' Note that the comparison is case-insensitive due to 'vbTextCompare'.
If StrComp(sPath, dPath, vbTextCompare) = 0 Then
MsgBox "You are trying to move this file to its current " _
& "location ('" & sPath & "').", vbExclamation, ProcName
Exit Sub
End If
Application.DisplayAlerts = False ' overwrite (without confirmation)
swb.SaveAs dPath ' save as new
Application.DisplayAlerts = True
Kill sPath ' delete old
Else ' the file has previously not been saved
dPath = dPath & dNotSavedFileExtension ' apppend the file extension
Application.DisplayAlerts = False ' overwrite (without confirmation)
swb.SaveAs dPath, dNotSavedFileFormat ' use 'FileFormat'
Application.DisplayAlerts = True
End If
' Inform showing the destination file path.
If InformWhenMoved Then
MsgBox "The new file location is '" & dPath & "'.", _
vbInformation, ProcName
End If
' Explore the destination file path's folder.
If ExploreNewLocation Then swb.FollowHyperlink swb.Path
End Sub