In the solutions looking for a problem to solve department…
I do like to have a system when naming files which is consistent, for example I always save correspondence files in the form YYYYMMDD xxxx Re: xxxxx, so for a letter to Centrelink written today the filename would be "20231129 Centrelink Re Pension ". This has the advantage that all correspondence is stored in time order.
Unfortunately in other areas I have been rather lax and my travel spreadsheets and lists are inconsistent sometimes “YYYY MM Trip Name”, sometimes YYYYMMDD, other times YYYY-MM. It was a mess. So on a wet arvo I decided to expell all this inconsistency and embrace consistencyby writing a VBA Script.
First a form:
Then some code:
Option Explicit
Private Sub cmdCancel_Click()
Unload Me
ActiveDocument.Close savechanges:=False
End Sub
Private Sub cmdEnter_Click()
Dim strSubject As String
Dim strTitle As String
Dim strPath As String
If Trim(txtMonth.Text) = "0" Or Trim(txtMonth.Text) = "" Or Trim(txtTrip.Text) = "" Then
MsgBox "Must Enter Month and Trip details", vbOKOnly, Title:="ERROR"
Exit Sub
End If
On Error Resume Next
'Create title string
strTitle = Trim(txtYear.Text) & "-" & Trim(txtMonth.Text) & Chr(32) & txtTrip.Text
'Create subject String
strSubject = MonthName(txtMonth.Text) & " " & Trim(txtYear.Text) & " - " & txtTrip.Text
With Dialogs(wdDialogFileSummaryInfo)
.Title = strTitle
.Subject = strSubject
.Execute
End With
'update all the fields
Selection.WholeStory
Selection.Fields.Update
Selection.HomeKey Unit:=wdLine
strPath = Environ("userprofile")
On Error Resume Next
Select Case Environ("computername")
Case "LEGION-PC"
' With Dialogs(wdDialogFileSaveAs)
' .Name = "D:\Libraries\Documents\OFFICE\Word\Travel\" & Format(txtMonth.Text, "YYYYmm") & " " & txtTrip.Text & ".docx"
' .Show
' End With
ActiveDocument.SaveAs2 FileName:="D:\Libraries\Documents\OFFICE\Word\Travel\" & strTitle & ".docx", FileFormat:=16
'ChangeFileOpenDirectory "D:\Libraries\Documents\OFFICE\Word\Travel" & "\Documents\OFFICE\Word\Travel\"
Case Else
ActiveDocument.SaveAs2 FileName:=strPath & "\Documents\OFFICE\Word\Travel\" & strTitle & ".docx", FileFormat:=16
'ChangeFileOpenDirectory strPath & "\Documents\OFFICE\Word\Travel\"
End Select
ErrTrap:
Unload Me
End Sub
Private Sub txtTrip_Exit(ByVal Cancel As MSForms.ReturnBoolean)
txtTrip.Text = StrConv(txtTrip.Text, vbProperCase)
txtTrip.Text = Replace(txtTrip.Text, "Nsw", "NSW")
txtTrip.Text = Replace(txtTrip.Text, "Nt", "NT")
txtTrip.Text = Replace(txtTrip.Text, "Sa", "SA")
txtTrip.Text = Replace(txtTrip.Text, "Wa", "WA")
End Sub
Private Sub UserForm_Initialize()
txtYear.Text = Year(Date)
txtMonth.SetFocus
End Sub
Private Sub txtMonth_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Dim X As Integer
X = KeyAscii
If X < 48 Or X > 57 Then
KeyAscii = 0
End If
End Sub
Private Sub txtYear_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Val(txtYear.Text) <> Year(Date) And Val(txtYear.Text) <> Year(Date) + 1 Then
txtYear.Text = Trim(Year(Date))
End If
End Sub
Private Sub txtMonth_Exit(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
If Len(txtMonth.Text) < 2 Then txtMonth.Text = "0" & txtMonth.Text
If CInt(txtMonth.Text) < 1 Or CInt(txtMonth.Text) > 12 Then
txtMonth.Text = ""
End If
End Sub
A good couple of hour’s work I thought, it was just a matter of copying it from the Word file to the Excel file and making the appropriate changes (very annoying that they do things differently)
After a bit of work with Bulk Rename Utility the folder now has a nice uniform look to it.
