CODEWITHSUNDEEP
excelvba
HSHO
HSHO

Reputation: 525

Open and repair multiple Excel files using VBA

I am using Google Sheets and making reports in Microsoft Excel. I am working on almost 50+ sheets. Each week I copy and paste data into Excel one by one to keep the cell formatting.

I tried to download the entire folder which contains Google Sheets then open it in Microsoft Excel. This gave me an error while opening each:
enter image description here

Once I click OK it populates one more error:
[enter image description here

How can I fix this error instead of opening each file separately then saving it to make it repairable (so the error could not appear again).

I tried with below code. I need to apply this method on the entire folder to repair all Excel files and save them.

Sub Folder()
Dim strFolder As String
Dim strFile As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim I As Long

With Application.FileDialog(4)
    If .Show Then
        strFolder = .SelectedItems(1)
    Else
        MsgBox "You haven't selected a folder!", vbExclamation
        Exit Sub
    End If
End With
If Right(strFolder, 1) <> "\" Then
    strFolder = strFolder & "\"
End If

Application.ScreenUpdating = False
strFile = Dir(strFolder & "*.xlsx*")
Do While strFile <> ""
    Set wbk = Workbooks.Open(strFolder & strFile, CorruptLoad:=XlCorruptLoad.xlRepairFile)
    For Each wsh In wbk.Worksheets
    Next wsh
    wbk.Close SaveChanges:=True
    strFile = Dir

    Exit Sub
Err_Open:
    Err.Clear
Loop

Application.ScreenUpdating = True
End Sub

Upvotes: 3

Views: 2375

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

Please, test the next code. It will create a subfolder "RecoveredWB" in the selected folder to be processed and all processed files will be saved in this one:

Sub Folder()
    Dim strFolder As String, strFile As String, wbk As Workbook
    Dim wsh As Worksheet, i As Long
    
    With Application.FileDialog(4)
        If .Show Then
          strFolder = .SelectedItems(1)
        Else
          MsgBox "You haven't selected a folder!", vbExclamation
          Exit Sub
        End If
    End With
    
    If Right(strFolder, 1) <> "\" Then
      strFolder = strFolder & "\"
    End If
    
    Dim wbName As String, arrWb, subFoldNew As String
    subFoldNew = strFolder & "RecoveredWB"
     'create RecoveredWB folder if not existing:
      If Dir(subFoldNew, vbDirectory) = "" Then MkDir subFoldNew
      
    Application.ScreenUpdating = False
    strFile = Dir(strFolder & "*.xlsx")
    Do While strFile <> ""
      Set wbk = Workbooks.Open(strFolder & strFile, CorruptLoad:=xlRepairFile)
      For Each wsh In wbk.Worksheets
      Next wsh
      
      arrWb = Split(wbk.fullname, "\") 'place the full name in an array split by "\"
      wbName = arrWb(UBound(arrWb)) 'the workbook name (without path)
      
      wbk.SaveCopyAs subFoldNew & "\" & wbName
      
      wbk.Close False
      
      strFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

The code is not tested, I cannot reproduce the situation, not having corrupted workbooks...

If something goes wrong, please explain which error on which code line, or what it does not against what it should.

Upvotes: 3

Related Questions