VBA/Macro - Move forlder

[acerlaptop]

Hi guys,

I have a code below that I'm currently working on. This code should move folder to another destination. But for some reason, the code moves the files inside the source folder, not the source folder itself.

Sub MOVE_FOLDER()

Dim FSO As Object
Dim sFolder As String, dFolder As String

sFolder = "H:\TEST\New folder\" & ActiveSheet.Range("D2").value
dFolder = "H:\TEST\New folder\" & ActiveSheet.Name
Set FSO = CreateObject("Scripting.FileSystemObject")

If Left(Right(sFolder, 7), 4) = ActiveSheet.Name Then
If Not FSO.FolderExists(dFolder) Then
FSO.MoveFolder Source:=sFolder, Destination:=dFolder
MsgBox "Folder Moved Successfully to The Destination", vbExclamation, "Done!"
Else
MsgBox "Folder Already Exists in the Destination", vbExclamation, "Folder Already Exists!"
End If
End If

End Sub

Any thoughts please?

Thanks

 

[acerlaptop]

Ok. I'm trying to help, but you're ignoring my questions and aren't answering.
ActiveWorksheet.Name = "2019", for example. Good. Got it.
Now I need to understand the real value of D2 cell. Can you tell me what do you have as a result of ?[d2] in the Immediate window, when your code is running please?

The value is "year"-Q1 -> example 2019-Q1
That's why I have Left(right(Sfolder, 7), 4) = ActiveSheet.Name to filter out all folder with 2019 in the name

Thanks

 

[LazyBug]

Try this.

Option Explicit

Sub MoveSubfolders()
Dim fso As Object, s As Object, sFolder As String, dFolder As String
Dim pthstr As String, fn As String
On Error GoTo ErrHandler

pthstr = "H:\TEST\New folder\"
sFolder = pthstr & ActiveSheet.Range("D2").Value
dFolder = pthstr & ActiveSheet.Name & "\"
Set fso = CreateObject("Scripting.FileSystemObject")

For Each s In fso.GetFolder(pthstr).subfolders
    If Left(Right(s, 7), 4) = ActiveSheet.Name Then
        fn = s.Name
        If Dir(dFolder, 16) = "" Then
            MkDir dFolder: s.Move dFolder
            MsgBox "New path " & dFolder & " has created and " & fn & " has moved"
        Else
            s.Move dFolder
            MsgBox "Folder " & fn & " has moved"
        End If
    Else
        MsgBox "Check the pattern and the paths"
    End If
Next s

ErrHandler: If Err.Number <> 0 Then MsgBox Err.Description
End Sub

 

[rlv01]

Could you start your code in VBE by pressing F8 key, and then write here the result of ?ActiveSheet.Name in the Immediate window?

Huh. Never knew you could do that with a question mark. I learned something new today. Thanks.

 

[LazyBug]

Huh. Never knew you could do that with a question mark. I learned something new today. Thanks.

Hello, rlv01! Thanks for the feedback, I'm glad was helpful.
Yeah, It is a very useful window for debugging (and it displays the intellisense as you type).

 

[acerlaptop]

Try this.

Option Explicit

Sub MoveSubfolders()
Dim fso As Object, s As Object, sFolder As String, dFolder As String
Dim pthstr As String, fn As String
On Error GoTo ErrHandler

pthstr = "H:\TEST\New folder\"
sFolder = pthstr & ActiveSheet.Range("D2").Value
dFolder = pthstr & ActiveSheet.Name & "\"
Set fso = CreateObject("Scripting.FileSystemObject")

For Each s In fso.GetFolder(pthstr).subfolders
    If Left(Right(s, 7), 4) = ActiveSheet.Name Then
        fn = s.Name
        If Dir(dFolder, 16) = "" Then
            MkDir dFolder: s.Move dFolder
            MsgBox "New path " & dFolder & " has created and " & fn & " has moved"
        Else
            s.Move dFolder
            MsgBox "Folder " & fn & " has moved"
        End If
    Else
        MsgBox "Check the pattern and the paths"
    End If
Next s

ErrHandler: If Err.Number <> 0 Then MsgBox Err.Description
End Sub

It's working now.

Thanks a LOT!!!

 

[LazyBug]

It's working now.

Glad to hear it. Thanks for the feedback.