Have a requirement to store a file in mydocuments. Save location has to be VDI or laptop independent.
I am able to successfully save the file, in the location I want. But with the same file name and location, I am unable to open it.
The path and the filename for workbooks.open is coming like this, when I am testing it thru VDI. Bit strange, I not able to open the workbook using the path I used to save it.
"\xxx.yyy.CO.NZ\PaleeS.home$\InsuranceAdvisory\Excel\DT_test delete_rectangle 1_04.May.17.xlsm"
Dim strFilename As String
Dim Client1 As Range
Dim Client2 As Range
Dim CurrentDate As String
Dim FilePrefix As String
Dim strDir As String
Dim StrDirSub As String
Dim Savedflie As String
Dim CurrentFolderpath As String
Dim CurrentFilename As String
CurrentFolderpath = Application.ActiveWorkbook.Path
CurrentFilename = Application.ActiveWorkbook.Path & "\" & Application.ActiveWorkbook.FullName
strDir = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & Application.PathSeparator & "\InsuranceAdvisory"
StrDirSub = strDir & "\Excel"
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
End If
Select Case Dir(StrDirSub, vbDirectory)
Case ""
MkDir StrDirSub
End Select
FilePrefix = "\DT_"
Set Client1 = Range("Client1")
Set Client2 = Range("Client2")
CurrentDate = Format(Date, "dd.mmm.yy")
strFilename = FilePrefix & Client1.Value & "_" & Client2.Value & "_" & CurrentDate
ActiveWorkbook.Save
ActiveWorkbook.SaveCopyAs StrDirSub & strFilename & ".xlsm"
Savedflie = StrDirSub & strFilename & ".xlsm"
Application.Workbooks.Open (Savedflie)
Related
from the below mentioned VBA code i am able to move files from Source to destination, however after moving the files i need to change the folder name by date everyday, is there anyway we can move the files directly to the updated date folder, the pattern of the folder name/folder date is
01102022
02102022
03102022
the code i have is
Option Explicit
Sub MoveFilesTEST()
Const sFolderPath As String = "E:\Asianet2"
Const dFolderPath As String = "E:\Asianet3"
Const FilePattern As String = "*.*"
MoveFiles sFolderPath, dFolderPath, FilePattern
End Sub
Sub MoveFiles( _
ByVal SourceFolderPath As String, _
ByVal DestinationFolderPath As String, _
Optional ByVal FilePattern As String = "*.*")
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(SourceFolderPath) Then
MsgBox "The source folder path '" & SourceFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
If Not fso.FolderExists(DestinationFolderPath) Then
MsgBox "The destination folder path '" & DestinationFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim apSep As String: apSep = Application.PathSeparator
Dim sPath As String: sPath = SourceFolderPath
If Left(sPath, 1) <> apSep Then sPath = sPath & apSep
Dim sFolder As Object: Set sFolder = fso.GetFolder(sPath)
If sFolder.Files.Count = 0 Then
Exit Sub
End If
Dim dPath As String: dPath = DestinationFolderPath
If Left(dPath, 1) <> apSep Then dPath = dPath & apSep
Dim dFolder As Object: Set dFolder = fso.GetFolder(dPath)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sFile As Object
Dim dFilePath As String
Dim ErrNum As Long
Dim MovedCount As Long
Dim NotMovedCount As Long
For Each sFile In sFolder.Files
dFilePath = dPath & sFile.Name
If fso.FileExists(dFilePath) Then
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
Else
On Error Resume Next
fso.MoveFile sFile.Path, dFilePath
ErrNum = Err.Number
' e.g. 'Run-time error '70': Permission denied' e.g.
' when the file is open in Excel
On Error GoTo 0
If ErrNum = 0 Then
MovedCount = MovedCount + 1
Else
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
End If
End If
Next sFile
Dim Msg As String
End Sub
screenshot
Please, use the next code. It creates the folder (as ddmmyyyy) in "dFolderPath" and moves all files existing in "sFolderPath":
Sub moveAllFilesInDateFolder()
Dim DateFold As String, fileName As String
Const sFolderPath As String = "E:\Asianet2"
Const dFolderPath As String = "E:\Asianet3"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy")' create the folder if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
If fileName = "" Then MsgBox "No any file in " & sFolderPath & "...": Exit Sub
Do While fileName <> ""
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
fileName = Dir
Loop
End Sub
Please, send some feedback after testing it...
You probably would need previously checking if there are no files in "dateFold", to avoid asking for overwriting in case of running the code twice (in the same day, by mistake)...
I am currently trying to put a macro together to sort files into folders based on a filename. I am locked into using VBA due to the system we are on.
For example sorting just the excel documents from below present in C:\ :
123DE.xls
124DE.xls
125DE.xls
124.doc
123.csv
into the following folder paths:
C:\Data\123\Data Extract
C:\Data\124\Data Extract
C:\Data\125\Data Extract
The folders are already created, and as in the example are named after the first x characters of the file. Batches of 5000+ files will need to be sorted into over 5000 folders so im trying to avoid coding for each filename
I am pretty new to VBA, so any guidance would be much appreciated. So far I have managed to move all the excel files into a single folder, but am unsure how to progress.
Sub MoveFile()
Dim strFolderA As String
Dim strFolderB As String
Dim strFile as String
strFolderA = "\\vs2-alpfc\omgusers7\58129\G Test\"
strFolderb = "\\vs2-alpfc\omgusers7\58129\G Test\1a\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) >0
Name StrFolderA & strFile As strFolderB & strFile
strFile = Dir
Loop
End Sub
Greg
EDIT
Sub MoveFile()
Dim strFolderA As String
Dim strFile As String
Dim AccNo As String
strFolderA = "\\vs2-alpfc7\omgUSERS7\58129\G Test\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) > 0
AccNo = Left(strFile, 2)
Name strFolderA & strFile As strFolderA & "\" & AccNo & "\Data Extract\" & strFile
strFile = Dir
Loop
End Sub
Thanks folks, are a few more bits and pieces i want to add, but functionality is there!
Sub DivideFiles()
Const SourceDir = "C:\" 'where your files are
Const topdir = "\\vs2-alpfc\omgusers7\58129\G Test\"
Dim s As String
Dim x As String
s = Dir(SourceDir & "\*.xls?")
Do
x = Left(s, 3) 'I assume we're splitting by first three chars
Name SourceDir & s As topdir & s & "\" & s
Loop Until s = ""
End Sub
If I understand you correctly, the problem is deriving the new fullpathname from the file name to use as the newpathname argument of the Name function.
If all of your files end with DE.XLS* you can do something like:
NewPathName = C:\Data\ & Split(strFile, "DE")(0) & "\Data Extract\" & strFile
You could use Filesystem object (tools > references > microsoft scripting runtime
This does a copy first then delete. You can comment out delete line and check copy is safely performed.
If on Mac replace "\" with Application.PathSeparator.
Based on assumption, as you stated, that folders already exist.
Option Explicit
Sub FileAway()
Dim fileNames As Collection
Set fileNames = New Collection
With fileNames
.Add "123DE.xls"
.Add "124DE.xls"
.Add "125DE.xls"
.Add "124.doc"
.Add "123.csv"
End With
Dim fso As FileSystemObject 'tools > references > scripting runtime
Set fso = New FileSystemObject
Dim i As Long
Dim sourcePath As String
sourcePath = "C:\Users\User\Desktop" 'where files currently are
For i = 1 To fileNames.Count
If Not fso.FileExists("C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\" & fileNames(i)) Then
fso.CopyFile (sourcePath & "\" & fileNames(i)), _
"C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\", True
fso.DeleteFile (sourcePath & "\" & fileNames(i))
End If
Next i
End Sub
Path = "Z:\Ebay\Suppliers Inventory\" & Fnumber & "\" & Fname & "\"
It works up to the last (& "\") then the Path will fail. My SKU is (XXX-000001) not sure if the dash is the problem and would be a pain to fix at this late date.
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Path As String
Dim GetPath As String
Dim Filename As String
Dim GetFileName As String
Dim Fname As String
Dim Fnumber As String
Fnumber = Me.FolderNumber
Fname = [SKU]
Path = "Z:\Ebay\Suppliers Inventory\" & Fnumber & "\" & Fname & "\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.InitialFileName = Path
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = False
If openDialog.Show Then
GetFileName = openDialog.SelectedItems(1)
Else
GetFileName = ""
End If
Forms![Items to List].ImageGroup.Form.PicText = GetFileName
Me.Image2 = GetFileName
I am trying to automate unzipping a zip file and extracting the files to a new folder location. I have scoured a bunch of sources and found code that will unzip the folder but it won't actually remove the files inside and put them in the new location, it just copies the zip folder and pastes it to the new location with the password removed. I want it to extract the files inside, and place them in the new folder. Thanks in advance for any help. Here is my code:
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim sPathTo7ZipExe As String
Dim sZipPassword As String
sPathTo7ZipExe = "C:\Riley\7Zip\7za.exe" ' <-- change this to where you installed the 7zip command line program
sZipPassword = "password" ' <-- change this to your zip password
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
'DefPath = Application.DefaultFilePath
DefPath = "C:\Riley\Visual Basic\" ' <-- make sure your path here ends in a \. you were missing that before
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
Shell sPathTo7ZipExe & " x -y -p" & sZipPassword & " -o""" & _
FileNameFolder & """ """ & Fname, vbHide
MsgBox "You find the files here: " & FileNameFolder
'On Error Resume Next
'Set FSO = CreateObject("scripting.filesystemobject")
'FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
I have a small piece of code under a command button click which saves the workbook file with a new name in a new location, I am wondering if it is possible to also automatically create a shortcut to that newly saved workbook in a different location?
Private Sub CommandButton1_Click()
Dim SelectedFNumber As String
Dim DateStr As String
Dim myFileName As String
Dim StorePath As String
DateStr = Format(Now, "dd.mm.yy HH.mm")
SelectedFNumber = Range("B4").Text
If SelectedFNumber <> "SELECT F NUMBER" And Range("D11") > "0" Then
StorePath = "G:\Targets\" & SelectedFNumber & "\"
myFileName = StorePath & SelectedFNumber & " " & DateStr & ".xlsm
If Len(Dir(StorePath, vbDirectory)) = 0 Then
MkDir StorePath
End If
ActiveWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
MsgBox "Select an F Number"
End If
End Sub
You basically need to add something like this:
Dim sShortcutLocation As String
sShortcutLocation = "C:\blah\workbook shortcut.lnk"
With CreateObject("WScript.Shell").CreateShortcut(sShortcutLocation)
.TargetPath = myFileName
.Description = "Shortcut to the file"
.Save
End With
changing the location to wherever you want.