Open all files in a folder, run a macro

[MOB]

I have 2,000 spreadsheets in a folder - I would like some code that;

- opens each spreadsheet one at a time
- in sheet "Summary", copy/paste special whole sheet
- in sheet "Summary", columns C&D - I only want the first letter of any text to remain (converting names to initials)
- delete all sheets except "Summary"
- save and close the file, but keep Excel open

Is this possible? I'm comfortable with VBA for most of the above except for opening each file in folder.

TIA

 

[KennyGreens]

Hi there, to open all files in a folder, you can use something like this below. Although I will say, I have a feeling that opening 2,000 files and executing those actions on each file that opens will probably take a solid amount of time, however I have never done anything like that on such a large scale.

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim MyFolder As String
Dim MyFile As String

MyFolder = "" 'Insert the path to the folder here
MyFile = Dir(MyFolder & "\*.xls*")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
MyFile = Dir
Loop

 

[mumps]

Open a new blank workbook or use an existing workbook. Place the macro below in a standard module. Change the file path and file extension (in red) to suit your needs. Keep in mind that as @KennyGreens suggested, with 2000 files, it will probably take some time to go through them all. I would also suggest that you create a new folder and copy 3 or 4 files from the 2000 files into that new folder and test the macro on those 3 or 4 files (don't forget to change the folder path to the new folder) to make sure that you are getting the expected results. This way if the macro is not working as expected, because the files are saved with the changes, you will still have the original files unchanged in your original folder.

Sub MOB()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wkbSource As Workbook, ws As Worksheet, rng As Range, temp As String
    Dim LastRow As Long
    Const strPath As String = "[COLOR="#FF0000"]C:\Test\[/COLOR]" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*[COLOR="#FF0000"].xlsx[/COLOR]")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            If ws.Name <> "Summary" Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
            End If
        With Sheets("Summary")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .UsedRange.Cells.Value = .UsedRange.Cells.Value
            For Each rng In .Range("C2:D" & LastRow)
                val = Split(rng, " ")
                For i = LBound(val) To UBound(val)
                    If temp = "" Then temp = Left(val(i), 1) Else temp = temp & Left(val(i), 1)
                Next i
                rng = temp
                temp = ""
            Next rng
        End With
        .Close savechanges:=True
        strExtension = Dir
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[mumps]

This version will not prompt you if you want to replace the existing file when saving the changes:

Sub MOB()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wkbSource As Workbook, ws As Worksheet, rng As Range, temp As String
    Dim LastRow As Long
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            If ws.Name <> "Summary" Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
            End If
        With Sheets("Summary")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .UsedRange.Cells.Value = .UsedRange.Cells.Value
            For Each rng In .Range("C2:D" & LastRow)
                Val = Split(rng, " ")
                For i = LBound(Val) To UBound(Val)
                    If temp = "" Then temp = Left(Val(i), 1) Else temp = temp & Left(Val(i), 1)
                Next i
                rng = temp
                temp = ""
            Next rng
        End With
        Application.DisplayAlerts = False
        .Close savechanges:=True
        Application.DisplayAlerts = True
        strExtension = Dir
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[MOB]

Apologies, I ended up parking this bit of work for a little while, I'll have a play now and report back

 

[MOB]

This bit is returning an error;

Val = Split(rng, " ")

"Compile Error - Function call on left hand side of assignment must return variant or object"

 

[mumps]

Oops! I for got to declare the variable. Try:

Sub MOB()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wkbSource As Workbook, ws As Worksheet, rng As Range, temp As String, LastRow As Long, Val As Variant
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            If ws.Name <> "Summary" Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
            End If
        With Sheets("Summary")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .UsedRange.Cells.Value = .UsedRange.Cells.Value
            For Each rng In .Range("C2:D" & LastRow)
                Val = Split(rng, " ")
                For i = LBound(Val) To UBound(Val)
                    If temp = "" Then temp = Left(Val(i), 1) Else temp = temp & Left(Val(i), 1)
                Next i
                rng = temp
                temp = ""
            Next rng
        End With
        Application.DisplayAlerts = False
        .Close savechanges:=True
        Application.DisplayAlerts = True
        strExtension = Dir
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[MOB]

Thanks - now says;

.Close savechanges:=True

"Compile Error - Invalid or unqualified reference"

You should be aware that while I dabble in the very basics of VBA, I'm not an expert at all so apologies if I ask stupid questions!

 

[mumps]

I should be apologizing for making silly omissions. Replace

.Close savechanges:=True

with

wkbSource.Close savechanges:=True

 

[MOB]

I've now got a "loop without Do" message