VBA renaming file and filling form using the parent folder name

[DeMoNloK]

Good morning and happy Friday!!
I have found a need to use vba to rename a file using the name of the parent folder name while also using the parent folder name to fill in portions of a form.
I have to do this quite often and the tedious process of copy-pasting the info from the parent folder into the form as well as having to wait for one drive to sync and rename the file as the folder name.

I would think this can be done while editing the file when done being able to press the button to do actions above and saving the file

Sub Test()

Dim oldName, newName
Dim ws As WorkSheet
Dim wb As Workbook 
oldName = ActiveWorkbook: newName = ActiveWorkbook.Path & "\"  ' Define file names.
Name oldName As oldName ' Rename file.

End Sub

Any help would be greatly appreciated.

 

[John_w]

I have found a need to use vba to rename a file using the name of the parent folder name while also using the parent folder name to fill in portions of a form.

Try running this macro on a test .xlsx workbook to rename it as the name of the parent folder. You'll need to give more details for the form filling part.

Public Sub Rename_Active_Workbook()

    Dim parts As Variant
    Dim parentFolder As String
    Dim oldFullName As String, newFullName As String
    
    With ActiveWorkbook
        oldFullName = .FullName
        parts = Split(.FullName, "\")
        parentFolder = parts(UBound(parts) - 1)
        newFullName = Left(.FullName, InStrRev(.FullName, "\")) & parentFolder & Mid(.FullName, InStrRev(.FullName, "."))
        If Dir(newFullName) <> vbNullString Then
            If MsgBox(newFullName & " already exists.  Overwrite?", vbYesNo + vbExclamation) = vbYes Then
                Application.DisplayAlerts = False  'suppress Excel replace file warning
                .SaveAs newFullName, .FileFormat
                Application.DisplayAlerts = True
                MsgBox newFullName & " overwritten.", vbInformation
            End If
        Else
            .SaveAs newFullName, .FileFormat
            Kill oldFullName
            MsgBox oldFullName & " renamed as " & newFullName, vbInformation
        End If
    End With
    
End Sub

 

[DeMoNloK]

Try running this macro on a test .xlsx workbook to rename it as the name of the parent folder. You'll need to give more details for the form filling part.

Public Sub Rename_Active_Workbook()

    Dim parts As Variant
    Dim parentFolder As String
    Dim oldFullName As String, newFullName As String
 
    With ActiveWorkbook
        oldFullName = .FullName
        parts = Split(.FullName, "\")
        parentFolder = parts(UBound(parts) - 1)
        newFullName = Left(.FullName, InStrRev(.FullName, "\")) & parentFolder & Mid(.FullName, InStrRev(.FullName, "."))
        If Dir(newFullName) <> vbNullString Then
            If MsgBox(newFullName & " already exists.  Overwrite?", vbYesNo + vbExclamation) = vbYes Then
                Application.DisplayAlerts = False  'suppress Excel replace file warning
                .SaveAs newFullName, .FileFormat
                Application.DisplayAlerts = True
                MsgBox newFullName & " overwritten.", vbInformation
            End If
        Else
            .SaveAs newFullName, .FileFormat
            Kill oldFullName
            MsgBox oldFullName & " renamed as " & newFullName, vbInformation
        End If
    End With
 
End Sub

Public Sub Rename_Active_Workbook()

Dim parts As Variant
Dim parentFolder As String
Dim oldFullName As String, newFullName As String

With ActiveWorkbook
oldFullName = .FullName
parts = Split(.FullName, "\")
parentFolder = parts(UBound(parts) - 1)
newFullName = Left(.FullName, InStrRev(.FullName, "\")) & parentFolder & Mid(.FullName, InStrRev(.FullName, "."))
If Dir(newFullName) <> vbNullString Then
If MsgBox(newFullName & " already exists. Overwrite?", vbYesNo + vbExclamation) = vbYes Then
Application.DisplayAlerts = False 'suppress Excel replace file warning
.SaveAs newFullName, .FileFormat
Application.DisplayAlerts = True
MsgBox newFullName & " overwritten.", vbInformation
End If
Else
.SaveAs newFullName, .FileFormat
Kill oldFullName
MsgBox oldFullName & " renamed as " & newFullName, vbInformation
End If
End With

End Sub
[/CODE]

Wow thx for such a quick reply, I have a word docx in another sub folder within the parent folder named inspections. The word docm has a table that has a predefined lay out that we add the same data from the parent folder name, the parent folder name has key information that will be added to the docm shown below. I have a macro in the docm that lets me use msofiledialog to add pictures using the file dialog then adding and updating TOC which I can hopefully incorporate the code you provided with small tweaks to vba excel to vba word using the new vba function. It seems like a huge task for a small quality of life task. We try to keep the naming consistent with - as a break between each part of the name.

 

[DeMoNloK]

Wow thx for such a quick reply, I have a word docx in another sub folder within the parent folder named inspections. The word docm has a table that has a predefined lay out that we add the same data from the parent folder name, the parent folder name has key information that will be added to the docm shown below. I have a macro in the docm that lets me use msofiledialog to add pictures using the file dialog then adding and updating TOC which I can hopefully incorporate the code you provided with small tweaks to vba excel to vba word using the new vba function. It seems like a huge task for a small quality of life task. We try to keep the naming consistent with - as a break between each part of the name.

View attachment 51697

Update first run, I'm gonna try an tweak code to get entire folder name as the rename of the excel sheet

 

[DeMoNloK]

Update first run, I'm gonna try an tweak code to get entire folder name as the rename of the excel sheet
View attachment 51699

Update

Option Explicit

Public Sub Rename_Active_Workbook()

    Dim parts As Variant
    Dim parentFolder As String
    Dim oldFullName As String, newFullName As String
 
    With ActiveWorkbook
        oldFullName = .FullName
        
        [COLOR=rgb(65, 168, 95)]parentFolder = ThisWorkbook.Path[/COLOR]
        newFullName = parentFolder & Mid(.FullName, InStrRev(.FullName, "."))
        If Dir(newFullName) <> vbNullString Then
            If MsgBox(newFullName & " already exists.  Overwrite?", vbYesNo + vbExclamation) = vbYes Then
                Application.DisplayAlerts = False  'suppress Excel replace file warning
                .SaveAs newFullName, .FileFormat
                Application.DisplayAlerts = True
                MsgBox newFullName & " overwritten.", vbInformation
            End If
        Else
            .SaveAs newFullName, .FileFormat
            Kill oldFullName
            MsgBox oldFullName & " renamed as " & newFullName, vbInformation
        End If
    End With
 
End Sub

File is name correct but has been saved within the parent folder I am going to try a live move into the quotes folder as part of the script

 

[DeMoNloK]

Update

Option Explicit

Public Sub Rename_Active_Workbook()

    Dim parts As Variant
    Dim parentFolder As String
    Dim oldFullName As String, newFullName As String
 
    With ActiveWorkbook
        oldFullName = .FullName
       
        [COLOR=rgb(65, 168, 95)]parentFolder = ThisWorkbook.Path[/COLOR]
        newFullName = parentFolder & Mid(.FullName, InStrRev(.FullName, "."))
        If Dir(newFullName) <> vbNullString Then
            If MsgBox(newFullName & " already exists.  Overwrite?", vbYesNo + vbExclamation) = vbYes Then
                Application.DisplayAlerts = False  'suppress Excel replace file warning
                .SaveAs newFullName, .FileFormat
                Application.DisplayAlerts = True
                MsgBox newFullName & " overwritten.", vbInformation
            End If
        Else
            .SaveAs newFullName, .FileFormat
            Kill oldFullName
            MsgBox oldFullName & " renamed as " & newFullName, vbInformation
        End If
    End With
 
End Sub

File is name correct but has been saved within the parent folder I am going to try a live move into the quotes folder as part of the script
View attachment 51700

I'm an idiot you had it built into the split, sorry for not paying attention.