Option Explicit
Sub List_Filenames_LIVE_Click()
'On Error GoTo ErrorHandle
' Refresh_Formulas Macro
'
Range("H7:J7").Select
Selection.Copy
Range("C7").Select
ActiveSheet.Paste
Application.GoTo Reference:="R500C3"
Range(Selection, Selection.End(xlUp)).Select
Range("C7:E500").Select
Range("C500").Activate
Application.CutCopyMode = False
Selection.FillDown
Range("A3").Select
'Make Sure Required Fields are Met
If IsEmpty(Range("Pri_Filename").Value) Then
MsgBox "Please Complete Field 1. and Try Again."
Exit Sub
End If
If IsEmpty(Range("Re_Filename").Value) Then
MsgBox "Please Complete Field 2. and Try Again."
Exit Sub
End If
If IsEmpty(Range("Initials").Value) Then
MsgBox "Please Complete Field 3. and Try Again."
Exit Sub
End If
If IsEmpty(Range("T_Date").Value) Then
MsgBox "Please Complete Field 4. and Try Again."
Exit Sub
End If
If IsEmpty(Range("Primary_Path").Value) Then
MsgBox "Please Enter Primary Folder Path and Try Again."
Exit Sub
End If
'Yes No Prompt
Dim YesNoPrompt As Variant
YesNoPrompt = MsgBox("List all files from 5. Primary Path?", vbYesNo, "")
If YesNoPrompt = vbNo Then
Exit Sub
End If
'Display File Path in A6 and File Names in B6
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(Range("Primary_Path").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name ROW 6, COL 2
Cells(i + 6, 2) = objFile.Name
'print file path
Cells(i + 6, 1) = objFile.Path
i = i + 1
Next objFile
'Paste Values on Output
Range("E7:E500").Select
Range("E500").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
'If Character Limit is Greater Than
If Range("Char_Limit").Value > 120 Then
MsgBox "Character limit exceeded. Shorten the File Output where necessary. Then Proceed to click the 'Rename Files' button."
Exit Sub
End If
'If No Errors Happen
MsgBox "File Paths Have Been Gennerated"
Exit Sub
Application.ScreenUpdating = True
'ErrorHandle:
'MsgBox "An Error Has Occured. Please Verify Your Primary Path and Try Again."
Application.ScreenUpdating = True
End Sub
Sub Rename_and_BackUp_LIVE_CLICK()
'Are You Sure?
Dim YesNoPrompt As Variant
YesNoPrompt = MsgBox("Rename Files?", vbYesNo, "")
If YesNoPrompt = vbNo Then
Exit Sub
End If
'If Character Limit is Greater Than
If Range("Char_Limit").Value > 120 Then
MsgBox "Character Limit Exceeded. Shorten Naming Convention of Flagged Files Below, and Try Again."
Exit Sub
End If
Call Create_BackUp
Exit Sub
End Sub
Sub Create_BackUp()
'Declare variables
Dim sourceFolder As String
Dim backupFolder As String
Dim fso As FileSystemObject
'Initialize variables
sourceFolder = Range("Primary_Path").Value
backupFolder = sourceFolder & "_backup"
'Create the FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
'Check if the source folder exists
If fso.FolderExists(sourceFolder) Then
'Check if the backup folder already exists
If fso.FolderExists(backupFolder) Then
'If the backup folder already exists, delete it
fso.DeleteFolder backupFolder
End If
'Create the backup folder
fso.CreateFolder backupFolder
'Copy the contents of the source folder to the backup folder
fso.CopyFolder sourceFolder, backupFolder
'Confirm that the backup was created successfully
'MsgBox "Backup of " & sourceFolder & " created at " & backupFolder
Else
'If the source folder doesn't exist, display an error message
MsgBox "Error: The source folder " & sourceFolder & " does not exist."
End If
Call Check_For_Dupes
Exit Sub
End Sub
Sub Check_For_Dupes()
'Check For Duplicates
Dim rng As Range
Dim cell As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Set the range to check for duplicates
Set rng = Range("E7:E500")
' Loop through each cell in the range
For Each cell In rng
' Skip blank cells
If cell.Value = "" Then
GoTo NextIteration
End If
' If the cell value is not in the dictionary, add it
If Not dict.Exists(cell.Value) Then
dict.Add cell.Value, 1
' If the cell value is already in the dictionary, it's a duplicate
Else
MsgBox "Duplicate value found: " & cell.Value
Exit Sub
End If
NextIteration:
Next cell
Call Rename_Files_LIVE_CLICK
Exit Sub
End Sub
Sub Rename_Files_LIVE_CLICK()
'Rename Files
Dim fso As New FileSystemObject
Dim fo As folder
Dim f As file
Dim last_row As Integer
Dim i As Integer
'On Error GoTo ErrorHandle:
last_row = Worksheets("MACRO TESTING").Cells(Rows.Count, 1).End(xlUp).Row
Set fo = fso.GetFolder(Worksheets("MACRO TESTING").Cells(2, 5).Value)
Dim new_name As String
For Each f In fo.Files
For i = 2 To last_row
If f.Name = Worksheets("MACRO TESTING").Cells(i, 1).Value Then
new_name = Worksheets("MACRO TESTING").Cells(i, 2).Value
f.Name = new_name
End If
Next
Next
Call RenameFolder_LIVE
'MsgBox "Done."
Exit Sub
'ErrorHandle:
'MsgBox "An Error Has Occured. Check Your Primary File Path and Try Again."
Exit Sub
End Sub
Sub RenameFolder_LIVE()
'On Error GoTo ErrorHandle:
'Declare a FileSystemObject
Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Get the current path from cell
Dim currentPath As String
currentPath = Range("Primary_Path").Value
'Get the new folder name from cell
Dim newName As String
newName = Range("Output_Folder").Value
'Rename the folder
fso.GetFolder(currentPath).Name = newName
MsgBox "Done. Verify files are renamed correctly, and proceed to upload to SharePoint. You can also revert to the BackUp if needed. Click 'Clear Previous Data' and proceed to the next file for renaming."
Exit Sub
'ErrorHandle:
'MsgBox "An Error Has Occured. Check Your Primary File Path and Try Again."
End Sub
Sub ClearPreviousData_LIVE_Click()
'
' Clear Previous Data
'
Dim YesNoPrompt As Variant
YesNoPrompt = MsgBox("Clear Previous Data?", vbYesNo, "")
If YesNoPrompt = vbNo Then
Exit Sub
End If
'Clear Data and Refresh Formulas
Application.GoTo Reference:="R500C1"
Range(Selection, Selection.End(xlUp)).Select
Range("A7:B500").Select
Range("A500").Activate
Selection.ClearContents
Range("A1").Select
Range("A2,B2,A5").Select
Range("A5").Activate
Selection.ClearContents
Range("A1").Select
'Refresh Formulas
Range("H7:J7").Select
Selection.Copy
Range("C7").Select
ActiveSheet.Paste
Application.GoTo Reference:="R500C3"
Range(Selection, Selection.End(xlUp)).Select
Range("C7:E500").Select
Range("C500").Activate
Application.CutCopyMode = False
Selection.FillDown
Range("A3").Select
End Sub
Sub Refresh_LIVE_CLICK()
' Refresh_Formulas Macro
'
Range("H7:J7").Select
Selection.Copy
Range("C7").Select
ActiveSheet.Paste
Application.GoTo Reference:="R500C3"
Range(Selection, Selection.End(xlUp)).Select
Range("C7:E500").Select
Range("C500").Activate
Application.CutCopyMode = False
Selection.FillDown
Range("A3").Select
End Sub
