We help IT Professionals succeed at work.

How to edit 2 cell fields in multiple excel files in a folder/subfolders automatically using VBA based on starting name of file

311 Views
Last Modified: 2020-09-18
How to edit 2 cell fields in multiple excel files in a folder/subfolders automatically using VBA based on starting name of file

For example I have a root folder of c:\master templates
Under that folder I have subfolders with clients names as the folders
Under each client folder I have folders with job numbers
Under those job number folders are the excel files that I want to change
They all start with the name of set_up sheet *
There could be 2 set_up sheet excel files or 3 or 5, it all varies based on client and job, but they are all named the same starting with "set_up sheet*"
I want to change 2 cells in each of these set_up sheet*.xls files for every directory/subdirectory that contains those files
Basically replace 2 fields
M14 with "Stick Out"
S14 with "Vending #"
Then I want to save each excel file back and close and then loop through and do the same thing for all the other excel files named the same thing in each directory/sub

Here is the code I have so far which I know isn't correct. It's just what I wrote by watching a youtube video on it. I know I am on the right track I just need some help

Sub LoopThroughDirectorytoedit()
Dim MyFile As String
Dim Filepath As String
Dim q As Long

Filepath = "C:\mastertemplates\"

MyFile = Dir(Filepath)

Do While Len(MyFile) > 0
If MyFile = "bookz.xlsm" Then
Exit Sub
End If

Workbooks.Open (Filepath & MyFile)
For q = 1 To Application.Worksheets.Count
Worksheets(q).Activate
Range("M14") = "Stick Out"
Range("S14") = "Vending #"
Next q
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop

End Sub





Thanks in advance
Comment
Watch Question

CERTIFIED EXPERT

Commented:
You can start with testing of this code (find all files in subfolders):
Sub LoopFolders()
    Dim fso As Object
    Dim f As Object, suser As Object, sjob As Object
    Dim ofile As Object
    Dim MyPath As String, MyFile As String, File As Workbook


    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("c:\master")
     'Starting folder
   For Each suser In f.SubFolders
       'User folders
      For Each sjob In suser.SubFolders
        'Job folders
        For Each ofile In sjob.Files
            If fso.GetExtensionName(ofile.Path) = "xls" Then
                If InStr(ofile.Name, "set_up sheet") = 1 Then
                            Debug.Print sjob & "\" & ofile.Name
                End If
            End If
        Next
      Next
    Next

End Sub

Open in new window

Author

Commented:
Thank you so much for replying to this
I tried to run the code you sent but nothing pops up when I run it?
I should be just importing a new module and then clicking the green arrow right?
Its supposed to output the filename of each setup_sheet file correct?
CERTIFIED EXPERT

Commented:
You should see file names in immediate window of debugger
like:
C:\master\user1\1\set_up sheet001.xls
If folder structure is different, I can correct code
CERTIFIED EXPERT

Commented:
Set correct starting folder in this line:
Set f = fso.GetFolder("c:\master")
May be it should be
Set f = fso.GetFolder("c:\master templates")

Author

Commented:
-1.JPGAttached is an example of the folder tree
CERTIFIED EXPERT

Commented:
Try
Set f = fso.GetFolder("c:\mastertemplates")

Author

Commented:
OK that is displaying correctly now

Author

Commented:
2.JPG
CERTIFIED EXPERT

Commented:
Now you can open each file and edit it
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
It's not clear which sheet(s) you want to make the changes in so the following code only changes the values on the first sheet in the workbooks that it finds.
Option Explicit

Sub LoopFolders()
Dim FileSystem As Object
Dim RootFolder As String

    RootFolder = "c:\mastertemplates\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")

    DoFolder FileSystem.GetFolder(RootFolder)
    
End Sub

Sub DoFolder(Folder As Object)
Dim wb As Workbook
Dim SubFolder As Object
Dim File As Object

    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next SubFolder
    
    For Each File In Folder.Files
        If File.Name Like "set_up sheet*" Then
            FixFile File.Path
        End If
    Next File
    
End Sub

Sub FixFile(strFilePath As String)
Dim wb As Workbook

    Set wb = Workbooks.Open(strFilePath)

    wb.Sheets(1).Range("M14").Value = "Stick Out"
    wb.Sheets(1).Range("S14").Value = "Vending #"
    
    wb.Close SaveChanges:=True
    
End Sub

Open in new window

Author

Commented:
So how do I add to that and replace these cells in all of those setup xls files that it finds?

Just these 2 cells need to be replaced

Range("M14") = "Stick Out"
Range("S14") = "Vending #"

Thank you soooo much for all your help on this
CERTIFIED EXPERT

Commented:
You can slightly modify your code:
Add function:
Sub editFile(fname As String)
Dim wb As Workbook
Dim q As Integer
Set wb = Workbooks.Open(fname)

For q = 1 To Application.Worksheets.Count
    Worksheets(q).Activate
    Range("M14") = "Stick Out"
    Range("S14") = "Vending #"
Next q
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

Open in new window

and replace debug line:
Debug.Print sjob & "\" & ofile.Name
with:
editFile (sjob & "\" & ofile.Name)
CERTIFIED EXPERT

Commented:
Full code
Sub LoopFolders()
    Dim fso As Object
    Dim f As Object, suser As Object, sjob As Object
    Dim ofile As Object
    Dim MyPath As String, MyFile As String, File As Workbook


    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("c:\mastertemplates")
     'Starting folder
   For Each suser In f.SubFolders
      'User folders
      For Each sjob In suser.SubFolders
        MyPath = f & "\" & suser & "\" & sjob & "\"
        'Job folders
        For Each ofile In sjob.Files
            If fso.GetExtensionName(ofile.Path) = "xls" Then
                If InStr(ofile.Name, "set_up sheet") = 1 Then
                          '   Debug.Print sjob & "\" & ofile.Name
                            editFile (sjob & "\" & ofile.Name)
                End If
            End If
        Next
      Next
    Next

End Sub

Sub editFile(fname As String)
Dim wb As Workbook
Dim q As Integer
Set wb = Workbooks.Open(fname)

For q = 1 To Application.Worksheets.Count
    Worksheets(q).Activate
    Range("M14") = "Stick Out"
    Range("S14") = "Vending #"
Next q
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

Open in new window

Author

Commented:
OK so a couple adjustments to this code

The only sheet in each workbook that needs to be changed is sheet1
also some of the files are named set up sheet instead of set_up sheet

Otherwise it worked great. You guys are awesome thanks2.JPG
Analyst Assistant
CERTIFIED EXPERT
Commented:
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION

Author

Commented:
This is exactly what I was looking for thank you so much. Is it also possible to replace the logo at the top of the excel file with another logo?

Same thing just want to replace cell 1 with a different logo/image on every setup sheet

Thank you so much

Author

Commented:
I will award the points back I just wanted to re-open this question quick

Author

Commented:
Is it also possible to replace the logo at the top of the excel file with another logo?

Same thing just want to replace cell 1 with a different logo/image on every setup sheet

Thank you so much
CERTIFIED EXPERT

Commented:
Do you have any other images there?
Upload sample template or make test (run this sub from your template file and show result in immediate window):
Sub Sub11()
    
    Dim shpTemp As Shape
    
    On Error Resume Next
    
    Debug.Print ActiveSheet.Name & " has " & ActiveSheet.Shapes.Count & " shapes"
    
    For Each shpTemp In ActiveSheet.Shapes
        Debug.Print shpTemp.Name, shpTemp.Type, ;
        Select Case shpTemp.Type
        Case msoAutoShape
            Debug.Print "Shape";
        Case msoCallout
            Debug.Print "Call out";
        Case msoCanvas
            Debug.Print "Canvas";
        Case msoChart
            Debug.Print "Chart";
        Case msoComment
            Debug.Print "Comment";
        Case msoDiagram
            Debug.Print "Diagram";
        Case msoEmbeddedOLEObject
            Debug.Print "EmbeddedOLEObject";
        Case msoFormControl
            Debug.Print "Forms Control";
        Case msoFreeform
            Debug.Print "Freeform";
        Case msoGroup
            Debug.Print "Group";
        Case msoLine
            Debug.Print "Line";
        Case msoLinkedOLEObject
            Debug.Print "LinkedOLEObject";
        Case msoLinkedPicture
            Debug.Print "LinkedPicture";
        Case msoOLEControlObject
            Debug.Print "OLEControlObject";
        Case msoPicture
            Debug.Print "Picture";
        Case msoScriptAnchor
            Debug.Print "Picture";
        Case msoShapeTypeMixed
            Debug.Print "ScriptAnchor";
        Case msoTable
            Debug.Print "Table";
        Case msoTextBox
            Debug.Print "Textbox";
        Case msoTextEffect
            Debug.Print "TextEffect";
        Case Else
            Debug.Print "Unknown shape item";
        End Select
        If Not shpTemp.TopLeftCell Is Nothing Then
            Debug.Print , Range(shpTemp.TopLeftCell, shpTemp.BottomRightCell).Address;
            Debug.Print ""
        Else
            Debug.Print ""
        End If
        
    Next
    
End Sub

Open in new window

CERTIFIED EXPERT

Commented:
You can test this code (but test it before use on real files):
Public Sub repl_picture()
    Dim shpTemp As Shape, ileft As Integer, itop As Integer
   If ActiveSheet.Shapes.Count = 0 Then Exit Sub
    On Error Resume Next
    For Each shpTemp In ActiveSheet.Shapes
        Debug.Print shpTemp.Name, shpTemp.Type
        If shpTemp.Type = msoPicture Or shpTemp.Type = msoLinkedPicture Then
            ileft = shpTemp.Left
            itop = shpTemp.Top
            shpTemp.Delete
            ' Correct path to logo file
            Set shpTemp = ActiveSheet.Shapes.AddPicture("c:\mastertemplates\logo.png", False, True, ileft, itop, -1, -1)
            Exit For
        End If
    Next
    On Error GoTo 0
End Sub

Open in new window


Add it to sub:
Sub FixFile(strFilePath As String)
Dim wb As Workbook

    Set wb = Workbooks.Open(strFilePath)

    wb.Sheets("Sheet1").Range("M14").Value = "Stick Out"
    wb.Sheets("Sheet1").Range("S14").Value = "Vending #"
    repl_picture
    wb.Close SaveChanges:=True
    
End Sub

Open in new window

Author

Commented:
Thanks for all the replies. Ok so a little more modification is needed because just replacing the logo isn't working. The old logo that is left behind in cell 1 is bigger than the logo that it is being replaced with so you can still see it in the background. That is why i need to delete the old logo and text box from cell1, basically delete everything in cell 1 and replace with new image.
Ex,



here is my code, but it isn't working

Option Explicit

Sub LoopFolders()
Dim FileSystem As Object
Dim RootFolder As String

    RootFolder = "c:\mastertemplates\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")

    DoFolder FileSystem.GetFolder(RootFolder)
    
End Sub

Sub DoFolder(Folder As Object)
Dim wb As Workbook
Dim SubFolder As Object
Dim File As Object

    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next SubFolder
    
    For Each File In Folder.Files
        If File.Name Like "set*up sheet*" Then
            FixFile File.Path
        End If
    Next File
    
End Sub

Public Sub repl_picture()
    Dim shpTemp As Shape, ileft As Integer, itop As Integer
   If ActiveSheet.Shapes.Count = 0 Then Exit Sub
    On Error Resume Next
    For Each shpTemp In ActiveSheet.Shapes
        Debug.Print shpTemp.Name, shpTemp.Type
        If shpTemp.Type = msoPicture Or shpTemp.Type = msoLinkedPicture Then
            ileft = shpTemp.Left
            itop = shpTemp.Top
            shpTemp.Delete
            ' Correct path to logo file
            Set shpTemp = ActiveSheet.Shapes.AddPicture("c:\mastertemplates\full.png", False, True, ileft, itop, -1, -1)
            Exit For
        End If
    Next
    On Error GoTo 0
End Sub

Sub deleteRow()
    Worksheets("Delete row").Rows(1).Delete
End Sub

Sub FixFile(strFilePath As String)
Dim wb As Workbook

    Set wb = Workbooks.Open(strFilePath)
    wb.Sheets("Sheet1").Range("M14").Value = "Stick Out"
    wb.Sheets("Sheet1").Range("S14").Value = "Vending #"
    repl_picture
    wb.Close SaveChanges:=True
    
End Sub

Open in new window

Author

Commented:
In addition I also need to turn off the compatibility check for excel, because it keeps popping up with popups and i have to click ok everytime and there are 1000's of files

Thanks
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
You can't turn off the compatibility checker for all workbooks, you need to do it for each workbook.

You can do that before you save the file.
Sub FixFile(strFilePath As String)
Dim wb As Workbook

    Set wb = Workbooks.Open(strFilePath)
    wb.Sheets("Sheet1").Range("M14").Value = "Stick Out"
    wb.Sheets("Sheet1").Range("S14").Value = "Vending #"
    repl_picture

    wb.CheckCompatibility = False
    wb.Close SaveChanges:=True
    
End Sub

Open in new window

Author

Commented:
OK Norrie understood got that part thanks very much

what about the below?

Thanks for all the replies. Ok so a little more modification is needed because just replacing the logo isn't working. The old logo that is left behind in cell 1 is bigger than the logo that it is being replaced with so you can still see it in the background. That is why i need to delete the old logo and text box from cell1, basically delete everything in cell 1 and replace with new image.
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
Do you have any other pictures/shapes on the sheet?

Author

Commented:
Yes

Sheet1 has 2 shapes
Picture 4      13           Picture       $H$1:$N$1
TextBox 1      17           Textbox       $P$1:$T$1
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
Is Picture 4 definitely not being deleted?

What do you see in the Immediate Window if you try this slightly adjusted version of repl_picture?
Public Sub repl_picture()
    Dim shpTemp As Shape, ileft As Integer, itop As Integer
   If ActiveSheet.Shapes.Count = 0 Then Exit Sub
    On Error Resume Next
    For Each shpTemp In ActiveSheet.Shapes
        Debug.Print shpTemp.Name, shpTemp.Type
        If shpTemp.Type = msoPicture Or shpTemp.Type = msoLinkedPicture Then
            ileft = shpTemp.Left
            itop = shpTemp.Top

            Debug.Pint "Deleting " & shpTemp.Name

            shpTemp.Delete
            ' Correct path to logo file
            Set shpTemp = ActiveSheet.Shapes.AddPicture("c:\mastertemplates\full.png", False, True, ileft, itop, -1, -1)
            Exit For
        End If
    Next
    On Error GoTo 0
End Sub

Open in new window

Author

Commented:
Picture 4      13
Deleting Picture 4
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
I'm a little confused.

That's telling me that Picture 4, which I assume is the logo, is being deleted but you say it's still there.

Author

Commented:
there is also a textbox that needs to be deleted

TextBox 1      17           Textbox       $P$1:$T$1

Thats why i wanted to delete everything in cell 1 unless you can just delete the textbox also?
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
This will delete both the picture and the textbox.
Public Sub repl_picture()
Dim shpTemp As Shape

    For Each shpTemp In ActiveSheet.Shapes
        shpTemp.Delete

    Next

    Set shpTemp = ActiveSheet.Shapes.AddPicture("c:\mastertemplates\full.png", False, True, Range("H1").Left, Range("H1").Top, -1, -1)

End Sub

Open in new window

Author

Commented:
That looks good but the picture now starts in collumn H1 and goes all the way to Z1
Can we make it so it starts in column A and goes to  collumn T?
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
I thought it was supposed to go where the old logo was and I thought that was H1.

Anyway, if it is to go in A1 change H1 to A1 in the following.
Set shpTemp = ActiveSheet.Shapes.AddPicture("c:\mastertemplates\full.png", False, True, Range("H1").Left, Range("H1").Top, -1, -1)

Open in new window

Author

Commented:
Awesome thanks for all the help
Worked perfectly

Author

Commented:
So I spoke too soon

Now we have one more issue

Some cells have data in them in the wrong field of R14, the data should be in S14, but if there is data in R14 can we replace that field instead?

For instance
R14 contains "cycle time" in some of the excel files
In about 90% of the files S14 contains "cycle time" and that is the data that needs to be replaced with Vending #

How can we check each file to see if Cycle Time is in R14 or S14 and then replace that cell with Vending#  22.JPGBecause right now some of the files have Cycle Time and Vending #

Like the one attached that is incorrect
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
Try this change to the FixFile sub.
Sub FixFile(strFilePath As String)
Dim wb As Workbook

    Set wb = Workbooks.Open(strFilePath)

    With wb.Sheets("Sheet1")

        .Range("M14").Value = "Stick Out"

        If .Range("R14").Value = "Cycle Time" Then
            .Range("R14").Value = "Vending #"
        End If

        If .Range("S14").Value = "Cycle Time" Then
            .Range("S14").Value = "Vending #"
        End If

        repl_picture

        .Close SaveChanges:=True

    End With

End Sub

Open in new window

Author

Commented:
Didnt work

Used this as a code
Option Explicit

Sub LoopFolders()
Dim FileSystem As Object
Dim RootFolder As String

    RootFolder = "O:\Master Templates\Wurth"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")

    DoFolder FileSystem.GetFolder(RootFolder)
    
End Sub

Sub DoFolder(Folder As Object)
Dim wb As Workbook
Dim SubFolder As Object
Dim File As Object

    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next SubFolder
    
    For Each File In Folder.Files
        If File.Name Like "set*up sheet*" Then
            FixFile File.Path
        End If
    Next File
    
End Sub

Public Sub repl_picture()
Dim shpTemp As Shape

    For Each shpTemp In ActiveSheet.Shapes
        shpTemp.Delete

    Next

    Set shpTemp = ActiveSheet.Shapes.AddPicture("O:\Master Templates\full.png", False, True, Range("A1").Left, Range("A1").Top, -1, -1)

End Sub

Sub FixFile(strFilePath As String)
Dim wb As Workbook

    Set wb = Workbooks.Open(strFilePath)

    With wb.Sheets("Sheet1")

        .Range("M14").Value = "Stick Out"

        If .Range("R14").Value = "Cycle Time" Then
            .Range("R14").Value = "Vending #"
        End If

        If .Range("S14").Value = "Cycle Time" Then
            .Range("S14").Value = "Vending #"
        End If

        repl_picture
        wb.CheckCompatibility = False
        wb.Close SaveChanges:=True

    End With[embed=file 1392432]

End Sub

Open in new window

22.JPG

Author

Commented:
Cycle time still remains in R14 and Vending # was put in S14
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
Do you want all the files to have the same values in the header row?

Author

Commented:
NO those will all be different
The only fields that need to be replaced are the ones in M14 and R14/S14 (whichever holds the cycle time value in that cell)
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
The code I posted will only change R14, or S14, if the contain the text 'Cycle Time'.

If they contain anything else, or are empty, those cells will remain untouched.

Author

Commented:
That is what it should do, but it didnt?

22.JPG

Author

Commented:
is it because its case sensitive Cycle time instead of Cycle Time?
NorieAnalyst Assistant
CERTIFIED EXPERT

Commented:
Oops, never spotted that.:)

Yes, it is case sensitive.

Try this.
Sub FixFile(strFilePath As String)
Dim wb As Workbook

    Set wb = Workbooks.Open(strFilePath)

    With wb.Sheets("Sheet1")

        .Range("M14").Value = "Stick Out"

        If UCase(.Range("R14").Value) = "CYCLE TIME" Then
            .Range("R14").Value = "Vending #"
        End If

        If UCase(.Range("S14").Value) = "CYCLE TIME" Then
            .Range("S14").Value = "Vending #"
        End If

        repl_picture
        wb.CheckCompatibility = False
        wb.Close SaveChanges:=True

    End With[embed=file 1392432]

End Sub

Open in new window

CERTIFIED EXPERT

Commented:
No comment has been added to this question in more than 21 days, so it is now classified as abandoned.

I have recommended this question be closed as follows:

Accept: Norie (https:#a42698196)

If you feel this question should be closed differently, post an objection and the moderators will review all objections and close it as they feel fit. If no one objects, this question will be closed automatically the way described above.

MacroShadow
Experts-Exchange Cleanup Volunteer

Gain unlimited access to on-demand training courses with an Experts Exchange subscription.

Get Access
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Empower Your Career
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE

Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.