A
Amitriumphs
Hi,
I want to include a macro in the following code which the InputBox
accepts SourceFolder name in the MMYYYY format only and no other
format else an error message is displayed. Example, if a folder exist
in C:\ drive by the name "$42007" then an error message be displayed
and macro should run only for "042007"
Here is the entire code in which i want my above criteria to be
included.
Any help would be appreciated.
Private Sub CommandButton1_Click()
Dim MMYYYY
Dim BegDate
Dim SourceFolder
Dim FN As String
Dim Dirname As String
Dim fs As Object
Message = "Please enter the Source folder name in the form MMYYYY as
present under path C:\, for Eg. 082006"
Title = "Date"
BegDate = InputBox(Message, Title)
Application.DisplayAlerts = False
If StrPtr(BegDate) = 0 Then
MsgBox "User hit cancel"
Exit Sub
ElseIf Len(BegDate) = 0 Then
MsgBox "User clicked OK with no input"
Exit Sub
End If
EndDate = Mid(BegDate, 1, 2) & "_" & Mid(BegDate, 3)
Application.DisplayAlerts = False
Set fs = CreateObject("Scripting.FileSystemObject")
Dirname = "C:\" & EndDate
SourceName = "C:\" & BegDate
If Not fs.FolderExists(SourceName) Then
MsgBox "Please enter the valid Source Folder Name"
Exit Sub
End If
If Not fs.FolderExists(Dirname) Then
fs.CreateFolder Dirname
Else
MsgBox "The Destination Folder Already Exist"
Exit Sub
End If
Application.ScreenUpdating = False
FileLocation = "c:\" & BegDate & "\" & "*.xls"
FN = Dir(FileLocation)
If FN = "" Then
MsgBox "No files Found in the Source Folder"
Exit Sub
End If
Do Until FN = ""
If Mid(FN, 4, 1) = "_" And Mid(FN, 5, 2) = Mid(BegDate, 1, 2)
Then
oldname = "C:\" & BegDate & "\" & FN
newname = "C:\" & EndDate & "\" & Mid(FN, 1, 3) & "_" &
Mid(BegDate, 1, 2) & "_" & Mid(BegDate, 3) & ".xls"
FileCopy oldname, newname
Else: MsgBox "Some or All files in the Source folder doesn't
have not a valid monthname. Only the files with valid monthname have
been transferred to destination folder"
Exit Sub
End If
FN = Dir
Loop
Application.ScreenUpdating = True
End Sub
Any help would be appreciated.
Thanks,
Amit
I want to include a macro in the following code which the InputBox
accepts SourceFolder name in the MMYYYY format only and no other
format else an error message is displayed. Example, if a folder exist
in C:\ drive by the name "$42007" then an error message be displayed
and macro should run only for "042007"
Here is the entire code in which i want my above criteria to be
included.
Any help would be appreciated.
Private Sub CommandButton1_Click()
Dim MMYYYY
Dim BegDate
Dim SourceFolder
Dim FN As String
Dim Dirname As String
Dim fs As Object
Message = "Please enter the Source folder name in the form MMYYYY as
present under path C:\, for Eg. 082006"
Title = "Date"
BegDate = InputBox(Message, Title)
Application.DisplayAlerts = False
If StrPtr(BegDate) = 0 Then
MsgBox "User hit cancel"
Exit Sub
ElseIf Len(BegDate) = 0 Then
MsgBox "User clicked OK with no input"
Exit Sub
End If
EndDate = Mid(BegDate, 1, 2) & "_" & Mid(BegDate, 3)
Application.DisplayAlerts = False
Set fs = CreateObject("Scripting.FileSystemObject")
Dirname = "C:\" & EndDate
SourceName = "C:\" & BegDate
If Not fs.FolderExists(SourceName) Then
MsgBox "Please enter the valid Source Folder Name"
Exit Sub
End If
If Not fs.FolderExists(Dirname) Then
fs.CreateFolder Dirname
Else
MsgBox "The Destination Folder Already Exist"
Exit Sub
End If
Application.ScreenUpdating = False
FileLocation = "c:\" & BegDate & "\" & "*.xls"
FN = Dir(FileLocation)
If FN = "" Then
MsgBox "No files Found in the Source Folder"
Exit Sub
End If
Do Until FN = ""
If Mid(FN, 4, 1) = "_" And Mid(FN, 5, 2) = Mid(BegDate, 1, 2)
Then
oldname = "C:\" & BegDate & "\" & FN
newname = "C:\" & EndDate & "\" & Mid(FN, 1, 3) & "_" &
Mid(BegDate, 1, 2) & "_" & Mid(BegDate, 3) & ".xls"
FileCopy oldname, newname
Else: MsgBox "Some or All files in the Source folder doesn't
have not a valid monthname. Only the files with valid monthname have
been transferred to destination folder"
Exit Sub
End If
FN = Dir
Loop
Application.ScreenUpdating = True
End Sub
Any help would be appreciated.
Thanks,
Amit