CODEWITHSUNDEEP
vbaexcel
Jonathan
Jonathan

Reputation: 315

VBA, loop directory, file causing error

I have a code that loops through directory, but when it reaches a certain file, I get a run time error 13. Type mismatch.

debug line:

measurement = ws.Evaluate("sumproduct((" & ws.Range(ws.Cells(2, i), ws.Cells(lrw, i)).Address & "<>"""")+0)") / (lrw - 1)

All the other files in my directory work fine, just this one. contains 3 sheets. Any ideas? I can open the file fine. The code actually works halfway through the workbook and stops in sheet 2. 

Sub stackmeup()
'added function to skip corrupt files works! Adding skipped files works.. and do something about 50%.
'changed lrw to long, doesnt skip those files now :)



Dim wb As Workbook, fileNames As Object, errCheck As Boolean 'part of loop


Dim ws As Worksheet
Dim resultSheet As Worksheet
Dim i As Long
Dim lco As Integer
Dim lrw As Long
Dim resultRow As Integer
Dim measurement As Double

'To compile skipped files
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")


Set resultSheet = Application.ActiveSheet
resultRow = 1

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
'get user input for files to search
  Set fileNames = CreateObject("Scripting.Dictionary")
  errCheck = UserInput.FileDialogDictionary(fileNames)
  If errCheck Then Exit Sub


For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
    Set wb = Nothing    ' or set a boolean error flag
End If
On Error GoTo 0    ' or custom error handler

If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
    Debug.Print "Successfully loaded " & fileNames(Key)
    wb.Application.Visible = False 'make it not visible


    For Each ws In wb.Worksheets
        If Not Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
            'define the range to measure
            lco = ws.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
            lrw = ws.Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
            If lrw = 1 Then lrw = 2
            For i = 1 To lco
                measurement = ws.Evaluate("sumproduct((" & ws.Range(ws.Cells(2, i), ws.Cells(lrw, i)).Address & "<>"""")+0)") / (lrw - 1)
                resultSheet.Cells(resultRow, 1).Value = wb.Name
                resultSheet.Cells(resultRow, 2).Value = ws.Name
                resultSheet.Cells(resultRow, 3).Value = ws.Cells(1, i).Value
                resultSheet.Cells(resultRow, 4).Style = "Percent"
                resultSheet.Cells(resultRow, 5).Value = measurement
                resultRow = resultRow + 1
            Next
        End If
    Next
    wb.Application.Visible = True '' I added
    wb.Close savechanges:=False 'close the workbook do not save
    Set wb = Nothing 'release the object
    End If
Next 'End of the fileNames loop

Set fileNames = Nothing
'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Function Col_Letter(lngCol As Long) As String
    Dim vArr
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function

Upvotes: 0

Views: 180

Answers (1)

Tim Williams
Tim Williams

Reputation: 166146

You can look for sheets which give an error using something like this:

Dim measurement As Variant
'...
'...

For i = 1 To lco

    On Error Resume Next
    measurement = ws.Evaluate("sumproduct((" & _
               ws.Range(ws.Cells(2, i), ws.Cells(lrw, i)).Address & _
               "<>"""")+0)") / (lrw - 1)
    On Error Goto 0

    With resultSheet.Rows(resultRow)
        .Cells(1).Value = wb.Name
        .Cells(2).Value = ws.Name
        .Cells(3).Value = ws.Cells(1, i).Value
        .Cells(4).Style = "Percent"
        .Cells(5).Value = IIf(IsError(measurement),"Error!",measurement)
    End With
    resultRow = resultRow + 1
Next

Upvotes: 2

Related Questions