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
Not only that, but not sure why you have 1000 in the Cells part there.
.Cells(Rows.Count, 1000) is literally referring to the cell at the intersection of column ALL and row 1048576
As if you wrote Range("ALL1048576")

Was that the intention there?
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Jonmo1 said:
Was that the intention there?
Click to expand...

Hi Jonmo,

Unfortunately I did not bookmark the place where I found this code, which I usually do. So I cannot find back the original code. But I read it as a 1000 possible rows that data could be in. And as the sum of A1003 minus A3.

It did generate a list of unique values where I wanted it however. I did try to replace the line you suggested and it gave me only 3 values starting at J2 where I wanted it to start at J3.

I replaced Macro 'UniqueMultichannel' with the following macro using an advanced filter.
Code: 
Public Sub Test()    Dim LR As Long
    LR = Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("A3:A" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("J3"), Unique:=True


End Sub
This generates the list as well except for the fact that this one is case sensitive, which I'm sure can be built in?? I want a1 and A1 to be seen as duplicates.

My problem with the UDF in column V that depends on the values generated by the UDF in column U remain however also when the list is created by using AdvancedFilter.

Thanks for your effort!!
 
Last edited:
Upvote 0
Found the original code here:VBA Macro To Create A New Column Of Unique Values From Another Column Of Duplicates

Code: 
[LEFT][COLOR=#333333]Sub NoDupes()[/COLOR][/LEFT]
    Dim sq() As Variant    With Sheets("Extract ESR")        sn = .Range("V2:V" & .Cells(Rows.Count, 22).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("Extract ESR").Range("W2").Resize(UBound(sq)) = WorksheetFunction.Transpose(sq) </pre>[LEFT][COLOR=#333333]End Sub[/COLOR][/LEFT]
 
Upvote 0
Bassey said:
But I read it as a 1000 possible rows that data could be in. And as the sum of A1003 minus A3.
Click to expand...
No, that's not quite what it does.

Try changing this line
sn = .Range("A3:A1003" & .Cells(Rows.Count, 1000).End(xlUp).Row)
to
sn = .Range("A3:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
 
Upvote 0
Could a workaround to my problem be a macro that replaces "=" by "=" within the formula's on my sheet? As manually doing this will refresh the calculation.

Already tried using the macro recorder on this, but running the recorded macro does not help as if it does not replace within the formula.
 
Upvote 0
Bassey said:
If I run macro 'All' Column V does not populate Should be done by macro's Ext5FormV and Ext6Formv2. If I manually rerun these macro's then the formula's in column V are autofilled, but the cells remain blank.

Only manually replacing "=" by "=", or manually copying and repasting column J will give all the results.

Also if I rerun the uniquemultichannel macro the whole sheet will go blank and column U will give #VALUE! errors.
Click to expand...

It all works OK for me.

Check that you don't have Calculation Options set to Manual.
 
Upvote 0
StephenCrump said:
It all works OK for me.
Click to expand...

I should probably clarify: I am focussing here on what appears to be "not working" for you.

I agree entirely with mole999's and Jonmo1's comments about your code.

There are also other problems to be tidied up later, e.g. your formula in column H should probably pass absolute, rather than relative, range arguments, and it would be good to clear columns H, I, J etc every time you create a new (potentially shorter) unique list.
 
Upvote 0
StephenCrump said:
It all works OK for me.
Click to expand...

Really?? Column V has result in each row that column J has results in as well?

What version of Excel do you use? Maybe I should try my sheet on a windows machine tomorrow. See if that make's a difference.

I do agree on the tidying up! Was thinking about a clear contents macro also. I came up with this:
Code: 
Sub ClearContent()    Dim LR As Long
    LR = Range("J" & Rows.Count).End(xlUp).Row
    Range("H4:Y" & LR).ClearContents
    Range("H3").ClearContents
    Range("U3").ClearContents
    Range("V3").ClearContents
    Range("J3").ClearContents
End Sub

But on the first try this gave me strange behaviour as well. As range k3:t3 is also deleted. How could this be?
 
Upvote 0
If I run Sub UniqueMultiChannel and Sub ALL, column V looks like this, and has formulae down the length of column J.
Here's the populated workbook after I run these two Subs: https://app.box.com/s/l9tj0q28eftiz1knj2ut

If I run your Sub ClearContent, LR returns 2, so Range("H4:Y" & LR).ClearContents will clear H2:Y4. Correct, but not what you intended!

To recap, your macros "work" for me, in the sense of producing formulae in several columns. We haven't addressed whether these formula are correct. Rather we have focussed on whether the formulae are populated in the right places.

For what it's worth, I use Excel 2010/13 32 bit on Win8 64 bit. My sense is that there is nothing in your macros that should behave differently on a Mac (but I'll cheerfully admit my Mac experience is zero). Let us know what your experience is on another machine.

Did you check the Calculation Options? .. I could replicate some of what you described by setting calculation to Manual.

Excel 2010
V

<tbody>
[TD="align: center"]1[/TD]
[TD="bgcolor: #3366FF, align: right"][/TD]

[TD="align: center"]2[/TD]
[TD="bgcolor: #3366FF, align: center"]Item Number Summary[/TD]

[TD="align: center"]3[/TD]
[TD="align: center"][/TD]

[TD="align: center"]4[/TD]
[TD="align: center"][/TD]

[TD="align: center"]5[/TD]
[TD="align: center"][/TD]

[TD="align: center"]6[/TD]
[TD="align: center"]451 - 454, 501 - 507[/TD]

[TD="align: center"]7[/TD]
[TD="align: center"]101, 102[/TD]

[TD="align: center"]8[/TD]
[TD="align: center"]201, 202[/TD]

[TD="align: center"]9[/TD]
[TD="align: center"][/TD]

[TD="align: center"]10[/TD]
[TD="align: center"][/TD]

[TD="align: center"]11[/TD]
[TD="align: center"][/TD]

[TD="align: center"]12[/TD]
[TD="align: center"]303 - 306[/TD]

[TD="align: center"]13[/TD]
[TD="align: center"]508 - 514[/TD]

[TD="align: center"]14[/TD]
[TD="align: center"]455 - 458[/TD]

[TD="align: center"]15[/TD]
[TD="align: center"][/TD]

[TD="align: center"]16[/TD]
[TD="align: center"][/TD]

[TD="align: center"]17[/TD]
[TD="align: center"][/TD]

[TD="align: center"]18[/TD]
[TD="align: center"]459 - 462, 515 - 521[/TD]

[TD="align: center"]19[/TD]
[TD="align: center"]103, 104[/TD]

</tbody>
Formule​
 
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,219
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