This is my first question on this platform, so please forgive any mistake I might make.
I have a couple of excel workbooks that I would like to make multiple exact changes to exact sheets and exact cells in all of them, but they are way too many to do individually.
I recorded all the changes I am to make in a macro using one of the workbooks;
Sub Macro1()
Range("W4:X4").Select
ActiveCell.FormulaR1C1 = "OFF -PEAK GEM(MW)"
Range("J33:M33").Select
ActiveCell.FormulaR1C1 = "Hz"
Range("B33:I33").Select
ActiveCell.FormulaR1C1 = "DETAILS"
Range("R34:X34").Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Range("R35:X35").Select
Selection.Cut
Range("R34").Select
ActiveSheet.Paste
Range("K68:L123").Select
Selection.Delete Shift:=xlToLeft
Range("K68:L68").Select
ActiveCell.FormulaR1C1 = "UNITS ON BAR"
Range("V178").Select
ActiveCell.FormulaR1C1 = "EXPECTED RESERVE"
Range("V179:V182").Select
End Sub
I ran this macro in another different unmodified workbook and it worked perfectly.
I'm quite new to using VBA, but I was able to find a block of code online that makes a change in multiple excel files in a specified directory;
Sub ChangeFiles()
Dim MyPath As String
Dim MyFile As String
Dim dirName As String
Dim wks As Worksheet
' Change directory path as desired
dirName = "c:\myfiles\"
MyPath = dirName & "*.xlsx"
MyFile = Dir(MyPath)
If MyFile > "" Then MyFile = dirName & MyFile
Do While MyFile <> ""
If Len(MyFile) = 0 Then Exit Do
Workbooks.Open MyFile
With ActiveWorkbook
For Each wks In .Worksheets
' Specify the change to make
wks.Range("A1").Value = "A1 Changed"
Next
End With
ActiveWorkbook.Close SaveChanges:=True
MyFile = Dir
If MyFile > "" Then MyFile = dirName & MyFile
Loop
End Sub
I edited it to fit my needs like so;
Sub ChangeFiles()
Dim MyPath As String
Dim MyFile As String
Dim dirName As String
Dim wks As Worksheet
Set wks = ActiveWorkbook.Worksheets("SHEET X")
' Change directory path as desired
dirName = "/Users/Account/Desktop/Directory 1/Directory 2/"
MyPath = dirName & "*.xls"
MyFile = Dir(MyPath)
If MyFile > "" Then MyFile = dirName & MyFile
Do While MyFile <> ""
If Len(MyFile) = 0 Then Exit Do
Workbooks.Open MyFile
With ActiveWorkbook
For Each wks In ActiveWorkbook.Worksheets
' Specify the change to make
wks.Range("W4:X4").Select
ActiveCell.FormulaR1C1 = "OFF -PEAK GEM(MW)"
wks.Range("J33:M33").Select
ActiveCell.FormulaR1C1 = "Hz"
wks.Range("B33:I33").Select
ActiveCell.FormulaR1C1 = "DETAILS"
wks.Range("R34:X34").Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
wks.Range("R35:X35").Select
Selection.Cut
wks.Range("R34").Select
ActiveSheet.Paste
wks.Range("K68:L123").Select
Selection.Delete Shift:=xlToLeft
wks.Range("K68:L68").Select
ActiveCell.FormulaR1C1 = "UNITS ON BAR"
wks.Range("V178").Select
ActiveCell.FormulaR1C1 = "EXPECTED RESERVE"
wks.Range("V179:V182").Select
Next
End With
ActiveWorkbook.Close SaveChanges:=True
MyFile = Dir
If MyFile > "" Then MyFile = dirName & MyFile
Loop
End Sub
I ran it and it did nothing and returned no error. I'm really at my wits' end here and I would really appreciate any help.
P.S I'm a mac user
Well, 120 simultaneous open tabs(no joke, I counted 😂) and two sleepless nights later, I finally found a solution. NOTE: THIS WORKS ON MAC ONLY, apparently I think Dir doesn't work on Mac, thanks to #Jeeped for pointing that out, so for other Mac users with my issue, this is what I did:
Option Explicit
'Important: this Dim line must be at the top of your module
Dim dirName As String
Sub ChangeFiles()
Dim MySplit As Variant
Dim FileIndirName As Long
Dim wks As Worksheet
'Clear dirName to be sure that it not return old info if no files are found
dirName = ""
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=1, FileFilterOption:=0, FileNameFilterStr:="SearchString")
If dirName <> "" Then
With Application
.ScreenUpdating = False
End With
MySplit = Split(dirName, Chr(13))
For FileIndirName = LBound(MySplit) To UBound(MySplit)
Workbooks.Open (MySplit(FileIndirName))
Set wks = ActiveWorkbook.Worksheets("SHEET X")
With wks
.Range("W4:X4") = "OFF -PEAK GEM(MW)"
.Range("J33:M33") = "Hz"
.Range("B33:I33") = "DETAILS"
.Range("R34:X34").EntireRow.Insert Shift:=xlShiftDown
.Range("R35:X35").Cut Destination:=Range("R34")
.Range("K68:L123").Delete Shift:=xlToLeft
.Range("K68:L68") = "UNITS ON BAR"
.Range("V178") = "EXPECTED RESERVE"
End With
ActiveWorkbook.Close SaveChanges:=True
Next FileIndirName
With Application
.ScreenUpdating = True
End With
Else
MsgBox "Sorry no files that match your criteria, A 0 files result can be due to Apple sandboxing: Try using the Browse button to re-select the folder."
With Application
.ScreenUpdating = True
End With
End If
MsgBox "Done!"
End Sub
'*******Function that do all the work that will be called by the macro*********
Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
FileFilterOption As Long, FileNameFilterStr As String)
'Ron de Bruin,Version 4.0: 27 Sept 2015
'http://www.rondebruin.nl/mac.htm
'Thanks to DJ Bazzie Wazzie and Nigel Garvey(posters on MacScripter)
Dim ScriptToRun As String
Dim folderPath As String
Dim FileNameFilter As String
Dim Extensions As String
On Error Resume Next
folderPath = MacScript("choose folder as string")
If folderPath = "" Then Exit Function
On Error GoTo 0
Select Case ExtChoice
Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)" 'xls, xlsx , xlsm, xlsb
Case 1: Extensions = "xls" 'Only xls
Case 2: Extensions = "xlsx" 'Only xlsx
Case 3: Extensions = "xlsm" 'Only xlsm
Case 4: Extensions = "xlsb" 'Only xlsb
Case 5: Extensions = "csv" 'Only csv
Case 6: Extensions = "txt" 'Only txt
Case 7: Extensions = ".*" 'All files with extension, use *.* for everything
Case 8: Extensions = "(xlsx|xlsm|xlsb)" 'xlsx, xlsm , xlsb
Case 9: Extensions = "(csv|txt)" 'csv and txt files
'You can add more filter options if you want,
End Select
Select Case FileFilterOption
Case 0: FileNameFilter = "'.*/[^~][^/]*\\." & Extensions & "$' " 'No Filter
Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\\." & Extensions & "$' " 'Begins with
Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\\." & Extensions & "$' " ' Ends With
Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\\." & Extensions & "$' " 'Contains
End Select
folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
Chr(34) & " to return quoted form of it's POSIX Path")
folderPath = Replace(folderPath, "'\''", "'\\''")
If Val(Application.Version) < 15 Then
ScriptToRun = ScriptToRun & "set foundPaths to paragraphs of (do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """)" & Chr(13)
ScriptToRun = ScriptToRun & "repeat with thisPath in foundPaths" & Chr(13)
ScriptToRun = ScriptToRun & "set thisPath's contents to (POSIX file thisPath) as text" & Chr(13)
ScriptToRun = ScriptToRun & "end repeat" & Chr(13)
ScriptToRun = ScriptToRun & "set astid to AppleScript's text item delimiters" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to return" & Chr(13)
ScriptToRun = ScriptToRun & "set foundPaths to foundPaths as text" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to astid" & Chr(13)
ScriptToRun = ScriptToRun & "foundPaths"
Else
ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """ "
End If
On Error Resume Next
dirName = MacScript(ScriptToRun)
On Error GoTo 0
End Function
By the way, #urdearboy thanks for your suggestion, it really helped, although I had problems with the .PasteSpecial, I still found a workaround.
For anyone wondering, what the code does when you run it is it basically brings up a dialog box asking you to chose your desired folder, when you do, it finds files with the .xls extension (you can change that) and performs the change in all .xls files in that folder.
Thanks to everyone who commented on this post. ^_^
Note: this is not meant to be a solution and will be deleted. Just wanted to make a suggestion for OP
You should update your excel operations as follows.
This Link will show you alternatives to the .Select method.
With wks
.Range("W4:X4") = "OFF -PEAK GEM(MW)"
.Range("J33:M33") = "Hz"
.Range("B33:I33") = "DETAILS"
.Range("R34:X34").Insert , CopyOrigin:=xlFormatFromLeftOrAbove
.Range("R35:X35").Copy
.Range("R35:x35").ClearContents
.Range("R34").PasteSpecial
.Range("K68:L123").Delete Shift:=xlToLeft
.Range("K68:L68") = "UNITS ON BAR"
.Range("V178") = "EXPECTED RESERVE"
End With
Related
I'm trying to convert my excel file to csv using visual studio and I'm having trouble converting it. I have looped my code to go through .xls or .xlsx file in a folder and convert each one of them to csv. However, I'm having no results at all :(
Textbox1.Text is the folder selected and Textbox2.Text is the destination folder.
Anyone can help me on this?
Here is my code:
Dim xls As Excel.Application
Dim strFile As String, strPath As String
xls = New Excel.Application
strPath = TextBox1.Text
strFile = Dir(strPath & "*.xls")
While strFile <> ""
xls.Workbooks.Open(strPath & strFile)
xls.ActiveWorkbook.SaveAs(Filename:=Replace(TextBox2.Text & strFile, ".xls", ".csv"), FileFormat:=Microsoft.Office.Interop.Excel.XlFileFormat.xlTextMSDOS)
xls.Workbooks.Application.ActiveWorkbook.Close(SaveChanges:=False)
strFile = Dir()
End While
xls.Quit()
Put this inside a text file and save it as Excel2Csv.vbs. Save it inside a folder containing all your excel files. Then just simply drag your excel files onto this .vbs file.
'* Usage: Drop .xl* files on me to export each sheet as CSV
'* Global Settings and Variables
Dim gSkip
Set args = Wscript.Arguments
For Each sFilename In args
iErr = ExportExcelFileToCSV(sFilename)
' 0 for normal success
' 404 for file not found
' 10 for file skipped (or user abort if script returns 10)
Next
WScript.Quit(0)
Function ExportExcelFileToCSV(sFilename)
'* Settings
Dim oExcel, oFSO, oExcelFile
Set oExcel = CreateObject("Excel.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
iCSV_Format = 6
'* Set Up
sExtension = oFSO.GetExtensionName(sFilename)
if sExtension = "" then
ExportExcelFileToCSV = 404
Exit Function
end if
sTest = Mid(sExtension,1,2) '* first 2 letters of the extension, vb's missing a Like operator
if not (sTest = "xl") then
if (PromptForSkip(sFilename,oExcel)) then
ExportExcelFileToCSV = 10
Exit Function
end if
End If
sAbsoluteSource = oFSO.GetAbsolutePathName(sFilename)
sAbsoluteDestination = Replace(sAbsoluteSource,sExtension,"{sheet}.csv")
'* Do Work
Set oExcelFile = oExcel.Workbooks.Open(sAbsoluteSource)
For Each oSheet in oExcelFile.Sheets
sThisDestination = Replace(sAbsoluteDestination,"{sheet}",oSheet.Name)
oExcelFile.Sheets(oSheet.Name).Select
oExcelFile.SaveAs sThisDestination, iCSV_Format
Next
'* Take Down
oExcelFile.Close False
oExcel.Quit
ExportExcelFileToCSV = 0
Exit Function
End Function
Function PromptForSkip(sFilename,oExcel)
if not (VarType(gSkip) = vbEmpty) then
PromptForSkip = gSkip
Exit Function
end if
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
sPrompt = vbCRLF & _
"A filename was received that doesn't appear to be an Excel Document." & vbCRLF & _
"Do you want to skip this and all other unrecognized files? (Will only prompt this once)" & vbCRLF & _
"" & vbCRLF & _
"Yes - Will skip all further files that don't have a .xl* extension" & vbCRLF & _
"No - Will pass the file to excel regardless of extension" & vbCRLF & _
"Cancel - Abort any further conversions and exit this script" & vbCRLF & _
"" & vbCRLF & _
"The unrecognized file was:" & vbCRLF & _
sFilename & vbCRLF & _
"" & vbCRLF & _
"The path returned by the system was:" & vbCRLF & _
oFSO.GetAbsolutePathName(sFilename) & vbCRLF
sTitle = "Unrecognized File Type Encountered"
sResponse = MsgBox (sPrompt,vbYesNoCancel,sTitle)
Select Case sResponse
Case vbYes
gSkip = True
Case vbNo
gSkip = False
Case vbCancel
oExcel.Quit
WScript.Quit(10) '* 10 Is the error code I use to indicate there was a user abort (1 because wasn't successful, + 0 because the user chose to exit)
End Select
PromptForSkip = gSkip
Exit Function
End Function
I have a script that is used to save an excel template based on the contents of two cells/named ranges (FailReportSN and FailReportDD). My issue is that the end users do not always remember to enter values into those two cells before running the save as script below. What I need to do is modify my current script to only save if there are values in both cells.
Sub saveAsFATPMM()
Dim PathMac As String, Path As String, FolderPath As String
If Application.PathSeparator = ":" Then
FolderPath = "Volumes:Server:Groups:METI:Quality Control:METIman:"
PathMac = FolderPath & Sheets("Failure Report").Range("FailReportSN").Text & _
" - FATP - " & Sheets("Failure Report").Range("FailReportDD").Text & ".xlsm"
'Format(Date, "mm-dd-yy")
ThisWorkbook.SaveAs Filename:=PathMac, FileFormat:=53, CreateBackup:=True
Else
FolderPath = "\\server\server\Groups\METI\Quality Control\METIman\"
Path = FolderPath & Sheets("Failure Report").Range("FailReportSN").Text & _
" - FATP - " & Sheets("Failure Report").Range("FailReportDD").Text & ".xlsm"
'Format(Date, "mm-dd-yy")
ThisWorkbook.SaveAs Filename:=Path, FileFormat:=52, CreateBackup:=True
End If
MsgBox "Your file has been saved. Thank you."
End Sub
Use conditional If to check for those values first. In the code below I check to make sure the Len of that Range is not 0 (or False in this case, since 0 equates to False here). I also refactored a bit to get rid of essentially duplicate code.
Sub saveAsFATPMM()
With Sheets("Failure Report")
If Len(.Range("FailReportSN")) And Len(.Range("FailReportDD")) Then
Dim PathMac As String, Path As String, FolderPath As String, fFormat as Long
If Application.PathSeparator = ":" Then
FolderPath = "Volumes:Server:Groups:METI:Quality Control:METIman:"
fFormat = 53
Else
FolderPath = "\\server\server\Groups\METI\Quality Control\METIman\"
fFormat = 52
End If
Path = FolderPath & .Range("FailReportSN").Text & _
" - FATP - " & .Range("FailReportDD").Text & ".xlsm"
ThisWorkbook.SaveAs Filename:=Path, FileFormat:=fFormat, CreateBackup:=True
MsgBox "Your file has been saved. Thank you."
Else
MsgBox "File not saved! Enter Fail Report Values and Try Again!"
End If
End With
End Sub
Okay here it is. I've done a bunch of coding in the last 3 or 4 months, learned a lot, BUT, I can't figure out why this code STILL opens a file when I hit cancel at the end once the popup window comes up showing my filtered filenames. Any advice would be highly appreciated.
Sub OpenByPartialName()
' Returns popup window with only filtered filenames matching
' Partial Filename input
Dim WB As Workbook
Dim Ans As String
Dim MyFile As String
Dim path As String
' Folder Path Name for Forms
path = ("S:\Forms Folder\")
Ans = InputBox("Enter Partial filename Filter", "Open File With Partial Name Filter")
MyFile = Dir("S:\Forms Folder\" & "*" & Ans & "*.xls")
MyFilter = path & "*" & Ans & "*.xls"
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = MyFilter
If .Show = 1 Then
MyFile = .SelectedItems(1)
End If
End With
On Error Resume Next
Set WB = Workbooks.Open(MyFile)
End Sub
That would be a dirty hack, but if you had an Else branch here:
If .Show = 1 Then
MyFile = .SelectedItems(1)
Else
MyFile = vbNullString
End If
...the code that actually opens the file could verify whether MyFile is empty or not before trying:
On Error Resume Next
If MyFile <> vbNullString Then Set WB = Workbooks.Open(MyFile)
That said I think you should be handling at least error 53 ("file not found") here, instead of just shoving all errors under the carpet.
Also the WB reference isn't used. Perhaps the Sub should be a Function that returns the opened workbook, or Nothing if opening fails?
This is what I use to select a directory. If the function returns an empty string, I don't try to open the file.
Private Function FolderPicker() As String
'*******************************************
' returns directory path to be printed to
' does not allow multiple selections,
' so returning the first item in selected
' items is sufficient.
'
' returns empty string On Error or if the
' user cancels
'********************************************
On Error GoTo ErrHandler
Const DefaultDirectory As String = "C:Path\to\default\directory\"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Choose Directory to Print to"
.InitialFileName = DefaultDirectory
.InitialView = msoFileDialogViewSmallIcons
If .Show <> -1 Then
FolderPicker = vbNullString
Else
FolderPicker = .SelectedItems(1)
End If
End With
Exit Function
ErrExit:
FolderPicker = vbNullString
Exit Function
ErrHandler:
MsgBox "Unexpected Error: " & Err.number & vbCrLf & "Source: " & Err.Source & _
"Description: " & Err.Description, vbCritical, "ERROR!"
Resume ErrExit
End Function
So, you would call it like this.
MyFile = FolderPicker
If MyFile <> vbNullString Then
Set WB = Workbooks.Open(MyFile)
End If
Much blood, sweat and tears later (Serious web surfing, cobbling code together and retesting) I have found an answer that works without any problems for pressing 'Cancel' at any point.
Sub OpenAuditPartialName()
' Returns popup window with only filtered
' filenames matching input criteria.
' Filenames are saved from another code that uses 3 variables to generate a _
' filename 'Filename part1_Filename part2_Filename part3 Forms.xls'
Dim WB As Workbook
Dim Ans As String
Dim MyFile As String
Dim path As String
' Folder path for Forms
path = ("S:\Forms Folder\")
Ans = InputBox("Enter any part of the filename to search by." & vbCrLf & vbCrLf & _
"Full or Partial information is OK." & vbCrLf & vbCrLf & "Filename part1" _
& vbCrLf & "Filename part2" & vbCrLf & "Filename part3", "Enter Partial Filename Filter")
' Exits on 'Cancel' as it should
If Ans = "" Then
Exit Sub
End If
MyFile = Dir(path & "*" & Ans & "*.xls")
MyFilter = path & "*" & Ans & "*.xls"
'*******************************************
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = MyFilter
' Now accepts the 'Cancel' instead of continuing to open the first file
' in the filtered list when pressed
If .Show = 0 Then
ElseIf Len(Ans) Then
MyFile = .SelectedItems(1)
On Error Resume Next
Set WB = Workbooks.Open(MyFile)
Else
Exit Sub
End If
'*******************************************
End With
End Sub
I have written a sub that should save worksheet 2 as a csv file with a time stamp in it. I let the user choose the file path with the get path sub, then when the user clicks 'okay' the program fails and says
run time error 9, subscript out of range.
Can you please help me figure out where/why my program is diong this?
Public Sub save()
Dim x As Integer
Dim FName As String
x = MsgBox("Are you sure?!?", vbYesNo, "Send File")
If x <> vbYes Then
GoTo Send_file_end:
End If
FName = get_path & "cambs_uplaoded_trades" & Format(Time, "hh mm ss") & ".csv"
ActiveWorkbook.Worksheets("sheet2").SaveAs Filename:=FName, FileFormat:=xlCSV
MsgBox "saved "
Send_file_end:
End Sub
here is my get path function
Function get_path() As String
Dim dlg As Variant
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
dlg.AllowMultiSelect = False
If dlg.Show <> -1 Then
get_path = ""
Else
get_path = dlg.SelectedItems(1) & "\"
End If
End Function
So i'll show you my solution just in case your interested:
Sheets("Sheet2").Activate
FName = get_path & "cambs_uplaoded_trades" & Format(Time, "hh mm ss") & ".csv"
ActiveWorkbook.Worksheets("Sheet2").SaveAs Filename:=FName, FileFormat:=xlCSV
MsgBox "saved "
ActiveSheet.Name = "Sheet2"
Sheets("Sheet1").Activate
So i activated sheet two before the name was changed, then saved it, then i changed the name of the active workshet back to sheet2.
thanks for you input!
When entering data into a .txt to act as a log, it does get quite large, several MB, and the generic txt reader for MS will have a conniption. Is there a way to put a log into a folder that may or may not exist? So in other words, if a folder doesn't exist, create folder, and cut and paste old log into new folder?
Since I know there will be possibilities for multiple logs to be in said log folder, would there be a way to make it so that there is today's date attached to the log name as well?
Think I solved it...
If FileLen(sLogFileName) > 3145728# Then
sLogFileName = "Open Order Log - " & Format(Date, "dd-mm-yyyy")
Name sLogFileName As "ThisWorkbook.path & Application.PathSeparator & \Temp\Open Order Log - " & Format(Date, "dd-mm-yyyy")
End If
From your other question, it is obvious that you know how to create a log file.
And from your above question, I could summarize that this is your query
Check if a folder exists or not
Creating a Folder
Add Date to a log file's name
Checking the file Size
Moving a File
So let's take them one by one.
Check if a folder exists or not. You can use the DIR function to check for that. See example below
Public Function DoesFolderExist(strFullPath As String) As Boolean
On Error GoTo Whoa
If Not Dir(strFullPath, vbDirectory) = vbNullString Then _
DoesFolderExist = True
Whoa:
On Error GoTo 0
End Function
Regarding your next query, you can use MKDIR to create a folder. See this example
Sub Sample()
MkDir "C:\Sample"
End Sub
Regarding the third query, you can create a log file with a date appended to it like this
Sub Sample()
Dim FlName As String
FlName = "Sample File - " & Format(Date, "dd-mm-yyyy")
Debug.Print FlName
End Sub
To check for a file size, you can use the FileLen function. See this example
Sub Sample()
Dim FileNM As String
FileNM = "C:\Sample.txt"
Debug.Print "The File size of " & FileNM & " is " & _
FileLen(FileNM) & " bytes"
End Sub
And to move a file from one directory to the other you can use the NAME function. See this example.
Sub Sample()
Dim FileNM As String
FileNM = "C:\Sample.txt"
Name FileNM As "C:\Temp\Sample.txt"
End Sub
So now you can put all of these together to achieve what you want :)
FOLLOWUP (FROM CHAT)
This is what we finally arrived at
Option Explicit
Dim PreviousValue
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
PreviousValue = Target(1).Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sLogFileName As String, ArchiveFileName As String
Dim ArchFolder As String, sLogMessage As String
Dim nFileNum As Long
Dim NewVal
On Error GoTo Whoa
Application.EnableEvents = False
sLogFileName = ThisWorkbook.path & Application.PathSeparator & _
"Open Order Log.txt"
If Not Target.Cells.Count > 1 Then
If Target.Value <> PreviousValue Then
'~~> Check if the Log File exists
If DoesFileFldrExist(sLogFileName) = True Then
'~~> Check for the File Size
If FileLen(sLogFileName) > 3145728 Then
'~~> Check if the "Log History" folder exists
ArchFolder = ThisWorkbook.path & _
Application.PathSeparator & "Log History"
'~~> If the "Log History" folder doesn't exist, then create it
If DoesFileFldrExist(ArchFolder) = False Then
MkDir ArchFolder
End If
'~~> Generate a new file name for the archive file
ArchiveFileName = ArchFolder & Application.PathSeparator & _
"Open Order Log - " & Format(Date, "dd-mm-yyyy") & ".txt"
'~~> Move the file
Name sLogFileName As ArchiveFileName
End If
End If
'~~> Check if the cell is blank or not
If Len(Trim(Target.Value)) = 0 Then _
NewVal = "Blank" Else NewVal = Target.Value
sLogMessage = Now & Application.UserName & _
" changed cell " & Target.Address & " from " & _
PreviousValue & " to " & NewVal
nFileNum = FreeFile
'~~> If the log file exists then append to it else create
'~~> a new output file
If DoesFileFldrExist(sLogFileName) = True Then
Open sLogFileName For Append As #nFileNum
Else
Open sLogFileName For Output As #nFileNum
End If
Print #nFileNum, sLogMessage
Close #nFileNum
End If
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Public Function DoesFileFldrExist(strFullPath As String) As Boolean
On Error GoTo Whoa
If Not Dir(strFullPath, vbDirectory) = vbNullString _
Then DoesFileFldrExist = True
Whoa:
On Error GoTo 0
End Function
Sub MoveFiles()
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Dim MyFile As String
Inlocation = ws.Range("A1").Value & "\"
Lastdate = Format(ws.Range("A3").Value, "DD-MM-YYYY")
Outlocation = ws.Range("A2").Value
Foulocation = Outlocation & "\" & Lastdate
MyFile = Dir(Inlocation & "*.*")
Set oFSO = CreateObject("Scripting.FileSystemObject")
'Check Specified Folder exists or not
If Not oFSO.FolderExists(Foulocation) Then
'If Folder is available
MkDir Foulocation
End If
Do Until MyFile = ""
oFSO.CopyFile Inlocation & MyFile, Foulocation & "\", True
If Inlocation <> Foulocation Then
oFSO.DeleteFile Inlocation & MyFile
End If
'Name Inlocation & MyFile As Foulocation & "\" & MyFile
MyFile = Dir
Loop
MsgBox "Files successfully moved to location " & Foulocation
End Sub