asked on

Cannot get VBA to paste a formula into range without error

I have vba code that opens multiple workbooks, generates an index/match lookup, and then sends it to a range. I need to do it this way because I want the results to show, with the workbooks closed, and Indirect does not work that way (I checked). Everything works well when all the lookup sheets are as expected. But when they are not (like the example, sheet name doesn't exist) I would just like the formula pasted and show a bad result, whatever it is. But instead Excel/VBA won't even continue with the rest of the paste and errors out. On Error Resume Next hides the error, but the problem still exists where the code doesn't finish with the rest of the formula paste. I know I can meticulously check for every case where the error might come up and tweak the formula I generate to avoid it, but I would like it to work as intended, if possible....

Sub WriteFormula()
    Dim sForm As String, sTick As String, sFile As String, sFileName As String, sSheetSummary As String, sSheetName As String
    Dim rTick As Range, rForm As Range, avTick As Variant, avForm As Variant, i As Long, lRowEnd As Long, bAskToUpdateLinks As Boolean
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        bAskToUpdateLinks = .AskToUpdateLinks
        .AskToUpdateLinks = False
    End With
    
    sSheetSummary = "Sheet1"
    sFileName = ".xlsx"
    sSheetName = " Data"

    With ThisWorkbook.Worksheets(sSheetSummary)
    
        lRowEnd = .Cells(.Rows.Count, 2).End(xlUp).Row
        Set rTick = .Range("B6:B" & lRowEnd)
        Set rForm = .Range("R6:R" & lRowEnd)

        avTick = rTick.Value2
        avForm = rForm.Value2
        
        On Error Resume Next
        For i = 1 To UBound(avTick)
            If Not IsEmpty(avTick(i, 1)) Then
                Workbooks.Open Filename:=ThisWorkbook.Path & "\" & avTick(i, 1) & sFileName, ReadOnly:=True
            End If
        Next i
        On Error GoTo 0
        
        For i = 1 To UBound(avTick)
            If Not IsEmpty(avTick(i, 1)) Then
                sTick = avTick(i, 1)
                sFile = "'" & "[" & sTick & sFileName & "]" & sTick & sSheetName & "'"
                sForm = "=INDEX(" & sFile & "!$1:$1048576,MATCH(R2," & sFile & "!$A:$A,0),MATCH(R3," & sFile & "!$3:$3,0))"
                avForm(i, 1) = sForm
            End If
            sForm = ""
            sFile = ""
            sTick = ""
        Next i
        
        'On Error Resume Next
        rForm.Formula = avForm
        'On Error GoTo 0
        
        On Error Resume Next
        For i = 1 To UBound(avTick)
            If Not IsEmpty(avTick(i, 1)) Then
                Workbooks(avTick(i, 1) & sFileName).Close SaveChanges:=False
            End If
        Next i
        On Error GoTo 0
    
    End With
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .AskToUpdateLinks = bAskToUpdateLinks
'        .AskToUpdateLinks = True
    End With

Open in new window

ASKER CERTIFIED SOLUTION

Subodh Tiwari (Neeraj)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

newparadigmz

ASKER

YES!!

I also had to create a WorkbookExists function to check first but absolutely this is what I was looking for!

Thank You

Subodh Tiwari (Neeraj)

You're welcome! Glad it worked as desired.

ste5an

hmm, the only two things:

1) drop that kind of error handling. While developing use no error handling at all. Change the code for document oriented processing.
2) I don't see why you need to use Value2 Write formulas to cell.FormulaR1C1 or cell.Formula.

So I would start by cleaning it up, e.g. this seems to do what you want:

Option Explicit

Sub WriteFormula()

  Const FIRST_USED_ROW As Long = 6
  Const SHEET_SUMMARY = "Sheet1"

  Dim SourceRange As Excel.Range
  Dim SummarySheet As Excel.Worksheet

  Dim LastUsedRow As Long
  Set SummarySheet = ActiveWorkbook.Worksheets(SHEET_SUMMARY)
  LastUsedRow = SummarySheet.Cells(SummarySheet.Rows.Count, 2).End(xlUp).Row
  Set SourceRange = SummarySheet.Range("B" & FIRST_USED_ROW & ":B" & LastUsedRow)
  Process SourceRange, 16, ActiveWorkbook.Path
  Set SourceRange = Nothing
  Set SummarySheet = Nothing

End Sub

Private Sub Process(ByRef ASourceRange As Excel.Range, ADestinationColumnOffset As Long, ByVal ABasePath As String)

  Const FILE_EXTENSION As String = ".xlsx"
  Const SHEET_SUFFIX As String = " Data"

  Dim SourceCell As Excel.Range

  Dim FileName As String
  Dim FileReference As String
  Dim Formula As String
  Dim FullFileName As String

  If Right(ABasePath, 1) <> "\" Then
    ABasePath = ABasePath & "\"
  End If

  For Each SourceCell In ASourceRange
    FileName = SourceCell.Value & FILE_EXTENSION
    FullFileName = ABasePath & FileName
    FileReference = "'[" & FileName & "]" & SourceCell.Value & SHEET_SUFFIX & "'"
    If Len(Dir(FullFileName)) > 0 Then
      Formula = Replace("=INDEX(#REF!$1:$1048576,MATCH(R2,#REF!$A:$A,0),MATCH(R3,#REF!$3:$3,0))", "#REF", FileReference)
      SourceCell.Offset(, ADestinationColumnOffset).Formula = Formula
    Else
      SourceCell.Offset(, ADestinationColumnOffset).Value = "File not found."
    End If
  Next SourceCell

End Sub

Open in new window

byundt

I added a # before the = in the formula, then looped through each cell in rForm to convert the text into a working formula. In so doing, you are able to see the formula that doesn't work.

Sub WriteFormula()
    Dim sForm As String, sTick As String, sFile As String, sFileName As String, sSheetSummary As String, sSheetName As String
    Dim cel As Range, rTick As Range, rForm As Range, avTick As Variant, avForm As Variant, i As Long, lRowEnd As Long, bAskToUpdateLinks As Boolean
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        bAskToUpdateLinks = .AskToUpdateLinks
        .AskToUpdateLinks = False
    End With
    
    sSheetSummary = "Sheet1"
    sFileName = ".xlsx"
    sSheetName = " Data"

    With ThisWorkbook.Worksheets(sSheetSummary)
    
        lRowEnd = .Cells(.Rows.Count, 2).End(xlUp).Row
        Set rTick = .Range("B6:B" & lRowEnd)
        Set rForm = .Range("R6:R" & lRowEnd)

        avTick = rTick.Value2
        avForm = rForm.Value2
        
        On Error Resume Next
        For i = 1 To UBound(avTick)
            If Not IsEmpty(avTick(i, 1)) Then
                Workbooks.Open Filename:=ThisWorkbook.Path & "\" & avTick(i, 1) & sFileName, ReadOnly:=True
            End If
        Next i
        On Error GoTo 0
        
        For i = 1 To UBound(avTick)
            If Not IsEmpty(avTick(i, 1)) Then
                sTick = avTick(i, 1)
                sFile = "'" & "[" & sTick & sFileName & "]" & sTick & sSheetName & "'"
                sForm = "#=INDEX(" & sFile & "!$1:$1048576,MATCH(R2," & sFile & "!$A:$A,0),MATCH(R3," & sFile & "!$3:$3,0))"
                avForm(i, 1) = sForm
            End If
            sForm = ""
            sFile = ""
            sTick = ""
        Next i
        
        On Error Resume Next
        rForm.Value = avForm
        For Each cel In rForm.Cells
            cel.Replace "#=", "="
            cel.Replace "=", "="
        Next
        On Error GoTo 0
        
        On Error Resume Next
        For i = 1 To UBound(avTick)
            If Not IsEmpty(avTick(i, 1)) Then
                Workbooks(avTick(i, 1) & sFileName).Close SaveChanges:=False
            End If
        Next i
        On Error GoTo 0
    
    End With
    
    With Application
        '.ScreenUpdating = True
        .DisplayAlerts = True
        .AskToUpdateLinks = bAskToUpdateLinks
'        .AskToUpdateLinks = True
    End With
End Sub

Open in new window