UDF Calculate issue that's wrecking my head....

B

Bassey

New Member
Joined
Jun 22, 2014
Messages
47
Hi,

Being a novice to Excel VBA I have managed to create a project that should and will make my work a lot easier. Thankfully I have used the many topics here to build my sheet. But now that is nearing completion I am running into some calculation issues on some of the UDF's I have used.

The sheet in question is buit in Excel 2011. Sheet "Formule" has lookup data in columns A through G and formula's in columns H through V. The formula's are mostly based on a unique list in column J that is calculated by the Sub below:

Code: 
Sub UniqueMultichannel()    Dim sq() As Variant
    With Sheets("Formule")
        sn = .Range("A3:A1003" & .Cells(Rows.Count, 1000).End(xlUp).Row)
    End With
    On Error Resume Next
    With New Collection
        For j = 1 To UBound(sn)
            .Add sn(j, 1), CStr(sn(j, 1))
        Next
        ReDim Preserve sq(.Count)
        For i = 1 To .Count
            sq(i - 1) = .Item(i)
        Next
    End With
    On Error GoTo 0
    Sheets("Formule").Range("Z3").Resize(UBound(sq)) = WorksheetFunction.Transpose(sq)
    MsgBox "Finished Unique Multichannels"
End Sub

After this Macro I want to populate the rest of the formula's to the lenght of the unique list in column J. My First try was to use autofill but at this point the columns containing UDF's are not calculating. So I tried to use ActiveCell.FormulaR1C1 wich solved some of it except for one Column "V" that wil only paste the formula in cell V3 and then it will refuse to calculate no matter what I try

I have formula:
Code: 
=IFERROR(LookUpConcatNoDup(J3;A3:A1003;E3:E1003);"")
In cell H3
In Cell U3 I have
Code: 
=IF(IF((J3="");"";(LookUpConcatNoC(J3;A3:A1003;D3:D1003)))="";"";(IF((J3="");"";(LookUpConcat(J3;A3:A1003;D3:D1003)))))
And in V3 I have:
Code: 
=IFERROR(CondenseList(U3);"")

This is the UDF's Code:
Code: 
Function LookUpConcat(ByVal SearchString As String, SearchRange As Range, ReturnRange As Range, _                      Optional Delimiter As String = ", ", Optional MatchWhole As Boolean = True, _
                      Optional UniqueOnly As Boolean = False, Optional MatchCase As Boolean = False)
                   
  Dim X As Long, CellVal As String, ReturnVal As String, Result As String
  
  If (SearchRange.Rows.Count > 1 And SearchRange.Columns.Count > 1) Or _
     (ReturnRange.Rows.Count > 1 And ReturnRange.Columns.Count > 1) Then
    LookUpConcat = CVErr(xlErrRef)
  Else
    If Not MatchCase Then SearchString = UCase(SearchString)
    For X = 1 To SearchRange.Count
      If MatchCase Then
        CellVal = SearchRange(X).Value
      Else
        CellVal = UCase(SearchRange(X).Value)
      End If
      ReturnVal = ReturnRange(X).Value
      If MatchWhole And CellVal = SearchString Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      ElseIf Not MatchWhole And CellVal Like "*" & SearchString & "*" Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      End If
Continue:
    Next
    
    LookUpConcat = Mid(Result, Len(Delimiter) + 1)
  End If
  
End Function


Function LookUpConcatNoC(ByVal SearchString As String, SearchRange As Range, ReturnRange As Range, _
                      Optional Delimiter As String = "", Optional MatchWhole As Boolean = True, _
                      Optional UniqueOnly As Boolean = False, Optional MatchCase As Boolean = False)
                   
  Dim X As Long, CellVal As String, ReturnVal As String, Result As String
  
  If (SearchRange.Rows.Count > 1 And SearchRange.Columns.Count > 1) Or _
     (ReturnRange.Rows.Count > 1 And ReturnRange.Columns.Count > 1) Then
    LookUpConcatNoC = CVErr(xlErrRef)
  Else
    If Not MatchCase Then SearchString = UCase(SearchString)
    For X = 1 To SearchRange.Count
      If MatchCase Then
        CellVal = SearchRange(X).Value
      Else
        CellVal = UCase(SearchRange(X).Value)
      End If
      ReturnVal = ReturnRange(X).Value
      If MatchWhole And CellVal = SearchString Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      ElseIf Not MatchWhole And CellVal Like "*" & SearchString & "*" Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      End If
Continue:
    Next
    
    LookUpConcatNoC = Mid(Result, Len(Delimiter) + 1)
  End If
  
End Function


Function LookUpConcatNoDup(ByVal SearchString As String, SearchRange As Range, ReturnRange As Range, _
                      Optional Delimiter As String = ", ", Optional MatchWhole As Boolean = True, _
                      Optional UniqueOnly As Boolean = True, Optional MatchCase As Boolean = False)
                   
  Dim X As Long, CellVal As String, ReturnVal As String, Result As String
  
  If (SearchRange.Rows.Count > 1 And SearchRange.Columns.Count > 1) Or _
     (ReturnRange.Rows.Count > 1 And ReturnRange.Columns.Count > 1) Then
    LookUpConcatNoDup = CVErr(xlErrRef)
  Else
    If Not MatchCase Then SearchString = UCase(SearchString)
    For X = 1 To SearchRange.Count
      If MatchCase Then
        CellVal = SearchRange(X).Value
      Else
        CellVal = UCase(SearchRange(X).Value)
      End If
      ReturnVal = ReturnRange(X).Value
      If MatchWhole And CellVal = SearchString Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      ElseIf Not MatchWhole And CellVal Like "*" & SearchString & "*" Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      End If
Continue:
    Next
    LookUpConcatNoDup = Mid(Result, Len(Delimiter) + 1)
  End If
  
End Function

Function CondenseList(aString As String, Optional Delimiter As String = ",") As String
    Dim Elements As Variant
    Dim lastNum As Double, Suffix As String, curElement As String
    Dim i As Long
    Dim continuationDelimiter As String
    
    Elements = Split(aString, Delimiter)
    lastNum = Val(Elements(0)) - 2
    continuationDelimiter = Delimiter
    For i = 0 To UBound(Elements)
        curElement = Elements(i)


        If IsNumeric(curElement) And (Val(curElement) = (lastNum + 1)) Then
            Suffix = continuationDelimiter & curElement
            continuationDelimiter = " -"
        Else
            CondenseList = CondenseList & Suffix & Delimiter & curElement
            Suffix = vbNullString
            continuationDelimiter = Delimiter
        End If
        
        lastNum = Val(curElement)
    Next i
    CondenseList = Mid(CondenseList & Suffix, Len(Delimiter) + 1)
End Function

And this is the macro I am using to populate the sheet:

Code: 
Sub ALL()
Extend1
Extend2
Ext3FormU
Ext4FormU2
Ext5FormV
Ext6Formv2
End Sub
Sub Extend1()    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("H3").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(LookUpConcatNoDup(RC[2],RC[-7]:R[1000]C[-7],RC[-3]:R[1000]C[-3]),"""")"
    Range("H3").Select
    Selection.AutoFill Destination:=Range("H3:H" & LR), Type:=xlFillDefault
End Sub


Sub Extend2()
    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("I3").AutoFill Destination:=Range("I3:I" & LR)
    Range("K3").AutoFill Destination:=Range("K3:K" & LR)
    Range("L3").AutoFill Destination:=Range("L3:L" & LR)
    Range("M3").AutoFill Destination:=Range("M3:M" & LR)
    Range("N3").AutoFill Destination:=Range("N3:N" & LR)
    Range("O3").AutoFill Destination:=Range("O3:O" & LR)
    Range("P3").AutoFill Destination:=Range("P3:P" & LR)
    Range("Q3").AutoFill Destination:=Range("Q3:Q" & LR)
    Range("R3").AutoFill Destination:=Range("R3:R" & LR)
    Range("S3").AutoFill Destination:=Range("S3:S" & LR)
    Range("T3").AutoFill Destination:=Range("T3:T" & LR)
    Range("W3").AutoFill Destination:=Range("W3:W" & LR)
    Range("X3").AutoFill Destination:=Range("X3:X" & LR)
    Range("Y3").AutoFill Destination:=Range("Y3:Y" & LR)
    MsgBox "Finished Extend 1"
End Sub


Sub Ext3FormU()
    Range("U3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(IF((RC[-11]=""""),"""",(LookUpConcatNoC(RC[-11],RC[-20]:R[1000]C[-20],RC[-17]:R[1000]C[-17])))="""","""",(IF((RC[-11]=""""),"""",(LookUpConcat(RC[-11],RC[-20]:R[1000]C[-20],RC[-17]:R[1000]C[-17])))))"
End Sub
Sub Ext4FormU2()
    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("U3").Select
    Selection.AutoFill Destination:=Range("U3:U" & LR), Type:=xlFillDefault
End Sub


Sub Ext5FormV()
    Range("V3").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(CondenseList(RC[-1]),"""")"
        End Sub


Sub Ext6Formv2()
    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("V3").Select
    Selection.AutoFill Destination:=Range("V3:V" & LR), Type:=xlFillDefault
End Sub

I tried making the Functions volatile with no results. Calculate sheet or f9 does nothing also macro's I tried to calculate the sheet didn't do anything at all.

What does work is going to Find replace and replacing "=" by "=". So a work around could be to replace "=" by "=" within the formula's using VBA? I would like the solution to be part of my macro to populate the sheet as other people than myself are going to work with the sheet as well.

What also works is manually coping and repasting the unique list in column J all the columns recalculate perfectly then. So perhaps there is also a problem in the way the unique list is created?

Also when I run macro 'All', Macro Ext6FormV2 is not executed. Not until the macro is run separately the formula will autofill, but the cells remain blank.

Spent the last couple of evenings trying to find a way to solve this, so hopefully one of you could push me in the right way?

Thank you and regards,

Sebastiaan
 
Sort by date Sort by votes
Just tried my sheet on a windows machine running Excel 2010 and no problems in column V.........Think I should try a clean install of my office 2011 now.......
 
Upvote 0

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
The formulas are correct and produce the information that I need.

Also I see the problem with my Clearcontent macro. There should be an 'if then' to find out if there are less than 3 positions in J. If so then no clearcontent is needed, if not then my macro should run. wil try and make the code tonight.

Thanx for all your effort Stephen!!

Btw....What exectly did you meen with the absolute and relative reference in column H?
 
Upvote 0
Fresh install didn't help......

Did write a sub to clear the contents and that works as I want it. The whole sequence to populate the sheet works as well except for the problem that column
V stops calculating as soon as it meets an empty cell in it's reference column U.http://wikisend.com/download/546364/Schermafbeelding 2014-08-07 om 23.41.17.png (Picture of the problem)

Am afraid that a manual replace "=" by "=" is the only workaround for now.....

The populate sequence looks like this now. I'm sure you will find some crude bits but it does what it should do.

Code: 
Sub ALL()Application.Calculation = xlCalculationAutomatic
Application.Wait Now + TimeValue("00:00:01")
Worksheets("Formule").Activate
Testclear
Application.Wait Now + TimeValue("00:00:01")
Testclear2
UniqueMultichannel
Extend1
Extend2
Ext3FormU
Ext4FormU2
Ext5FormV
Ext6Formv2
MsgBox "Is it working now?"


End Sub


Sub Testclear()
    With Sheets("Formule")
    Dim LR As Long
    LR = Sheets("Formule").Range("J" & Rows.Count).End(xlUp).Row
    If LR <= 3 Then
    Sheets("Formule").Range("H3,U3,V3").ClearContents
    Else
    Sheets("Formule").Range("H4:Y" & LR).ClearContents
    Application.Wait Now + TimeValue("00:00:05")
   End If
    End With
    On Error Resume Next
End Sub


Sub Testclear2()
    With Sheets("Formule")
    Range("H3,U3,V3").ClearContents
    Application.Wait Now + TimeValue("00:00:02")
    Range("J3").ClearContents
    MsgBox "Sheet Cleared"
        End With
    On Error Resume Next
End Sub


Sub UniqueMultichannel()
    Dim sq() As Variant
    With Sheets("Formule")
        sn = .Range("A3:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
    End With
    On Error Resume Next
    With New Collection
        For j = 1 To UBound(sn)
            .Add sn(j, 1), CStr(sn(j, 1))
        Next
        ReDim Preserve sq(.Count)
        For i = 1 To .Count
            sq(i - 1) = .Item(i)
        Next
    End With
    On Error GoTo 0
    Sheets("Formule").Range("J3").Resize(UBound(sq)) = WorksheetFunction.Transpose(sq)
    MsgBox "Finished Unique Multichannels"
End Sub


Sub Extend1()
    With Sheets("Formule")
    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("H3").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(LookUpConcatNoDup(RC[2],RC[-7]:R[1000]C[-7],RC[-3]:R[1000]C[-3]),"""")"
    Range("H3").Select
    Selection.AutoFill Destination:=Range("H3:H" & LR), Type:=xlFillDefault
        End With
    On Error Resume Next
End Sub


Sub Extend2()
    With Sheets("Formule")
    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("I3").AutoFill Destination:=Range("I3:I" & LR)
    Range("K3").AutoFill Destination:=Range("K3:K" & LR)
    Range("L3").AutoFill Destination:=Range("L3:L" & LR)
    Range("M3").AutoFill Destination:=Range("M3:M" & LR)
    Range("N3").AutoFill Destination:=Range("N3:N" & LR)
    Range("O3").AutoFill Destination:=Range("O3:O" & LR)
    Range("P3").AutoFill Destination:=Range("P3:P" & LR)
    Range("Q3").AutoFill Destination:=Range("Q3:Q" & LR)
    Range("R3").AutoFill Destination:=Range("R3:R" & LR)
    Range("S3").AutoFill Destination:=Range("S3:S" & LR)
    Range("T3").AutoFill Destination:=Range("T3:T" & LR)
    Range("W3").AutoFill Destination:=Range("W3:W" & LR)
    Range("X3").AutoFill Destination:=Range("X3:X" & LR)
    Range("Y3").AutoFill Destination:=Range("Y3:Y" & LR)
        End With
    On Error Resume Next
End Sub


Sub Ext3FormU()
    With Sheets("Formule")
    Range("U3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(IF((RC[-11]=""""),"""",(LookUpConcatNoC(RC[-11],RC[-20]:R[1000]C[-20],RC[-17]:R[1000]C[-17])))="""","""",(IF((RC[-11]=""""),"""",(LookUpConcat(RC[-11],RC[-20]:R[1000]C[-20],RC[-17]:R[1000]C[-17])))))"
        End With
    On Error Resume Next
End Sub
Sub Ext4FormU2()
    With Sheets("Formule")
    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("U3").Select
    Selection.AutoFill Destination:=Range("U3:U" & LR), Type:=xlFillDefault
        End With
    On Error Resume Next
End Sub


Sub Ext5FormV()
    With Sheets("Formule")
    Range("V3").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(CondenseList(RC[-1]),"""")"
            End With
    On Error Resume Next
        End Sub


Sub Ext6Formv2()
    With Sheets("Formule")
    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("V3").Select
    Selection.AutoFill Destination:=Range("V3:V" & LR), Type:=xlFillDefault
    MsgBox "Sheet has been Populated"
        End With
    On Error Resume Next
End Sub

Thank everyone for your time!
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA Search box and button code
Replies
0
Views
247
jlcodes
J
C
  • Question Question
How to get my macro to stop at the last recognized line
Replies
6
Views
544
Coco1
C
E
  • Question Question
VBA code clean up
Replies
9
Views
536
mumps
mumps
Guna13
  • Solved
Vlookup and Index Match Formula Calculating Issue - running more than 20 Minutes for 3L lines
Replies
1
Views
746
Anthony47
A
M
  • Question Question
Cleaning up Code
Replies
0
Views
796
MHamid
M

Forum statistics

Threads
1,223,888
Messages
6,175,217
Members
452,619
Latest member
Shiv1198

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top