Macro that changes a cell in each file within a folder

[Peter33]

Hello,
I'm having a bugger of a time with my macro (pasted below). The macro is supposed to be written to make changes in each excel file within a folder. Specifically I want to copy paste a value from one worksheet to another (in the same file) and then save and close. The idea is to repeat this for all of the 3,000 files in the folder.

When I run the macro, the hour glass starts to work and after about 20 seconds or so it stops and no changes were made. I am attaching the file that has the macro in it, as well as one of the 3,000 files that I am trying to change.

Any help would be appreciated.
Thanks from Seattle,
Peter

Sub ProAddJobCostingDate()
With Application.FileSearch
.LookIn = "F:\Excel"
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then

Set newwkbk = ActiveWorkbook

For i = 1 To .FoundFiles.Count
Set wkbk = Workbooks.Open(.FoundFiles(i))
Call Sheets("Individuals").Select
    Range("f1").Select
    Selection.Copy
    Sheets("JobCosting").Select
    Range("l1").Select
    ActiveSheet.Paste
    ActiveWorkbook.save
    ActiveWorkbook.Close

Next i
End If
End With
End Sub

[shg]

Do the workbooks have macros? Do they take a long time to calculate?

[Peter33]

None of the workbooks have their own macros. The only macro is in the Crew99999 file (one that was attached to this posing). I keep it in the same folder as the other (3,000) files and use it to run all of the other files in the folder. I don't know if this is the "right" way to do things, but I do not know any other way.

-Peter

[shg]

Try this:

Sub ProAddJobCostingDate()
    Dim i As Long
    
    With Application.FileSearch
        .LookIn = "F:\Excel"
        .Filename = "*.xls"
        .FileType = msoFileTypeExcelWorkbooks
        
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                Workbooks.Open .FoundFiles(i)
                Worksheets("Individuals").Range("F1").Copy _
                    Destination:=Worksheets("JobCosting").Range("L1")
                ActiveWorkbook.Close Savechanges:=True
            Next i
        End If
    End With
End Sub

If that works, you can turn ScreenUpdating off during execution to speed things up.

[jaslake]

I'm only guessing what you're attempting to do based on a step through of the macro in WB 01-01-01#Crew 9999.xls.
It appears as if you're trying to copy the date from Cell F1 of WB 01-01-01#Crew 9999.xls (Week Ending: 2/18/2006) to WB 01-07-06#Crew 23.xls, WS Individuals Cell F1 and WS JobCosting Cell L1.

If this is what you're attempting to do, try this code

Option Explicit

Sub ProAddJobCostingDate()
    Dim i As Long
    Dim Wb1 As Workbook

    Set Wb1 = ActiveWorkbook
    With Application.FileSearch

        .LookIn = "F:\Excel"
        .Filename = "*.xls"
        .FileType = msoFileTypeExcelWorkbooks

        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count

                If (.FoundFiles(i)) <> .LookIn & "\" & ActiveWorkbook.Name Then

                    Workbooks.Open .FoundFiles(i)
                    Wb1.Worksheets("Individuals").Range("F1").Copy _
                            Destination:=Worksheets("JobCosting").Range("L1")
                    Wb1.Worksheets("Individuals").Range("F1").Copy _
                            Destination:=Worksheets("Individuals").Range("F1")

                    ActiveWorkbook.Close Savechanges:=True
                End If
            Next i
        End If
    End With
End Sub

If this is not what you're after, let me know. J

[Peter33]

This worked. Thanks. I'm still new to VBA so I appreciate the help. It a whole new language, but one with tons of potential I am finding.