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

[Bassey]

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:

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:

=IFERROR(LookUpConcatNoDup(J3;A3:A1003;E3:E1003);"")

In cell H3
In Cell U3 I have

=IF(IF((J3="");"";(LookUpConcatNoC(J3;A3:A1003;D3:D1003)))="";"";(IF((J3="");"";(LookUpConcat(J3;A3:A1003;D3:D1003)))))

And in V3 I have:

=IFERROR(CondenseList(U3);"")

This is the UDF's 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:

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

 

[Jonmo1]

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?

 

[Bassey]

Was that the intention there?

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.

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!!

 

[Bassey]

Found the original code here:VBA Macro To Create A New Column Of Unique Values From Another Column Of Duplicates

[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]

 

[Jonmo1]

But I read it as a 1000 possible rows that data could be in. And as the sum of A1003 minus A3.

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)

 

[Bassey]

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)

Yes, this generates the same list as before. Thank you.

 

[Bassey]

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.

 

[StephenCrump]

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.

It all works OK for me.

Check that you don't have Calculation Options set to Manual.

 

[StephenCrump]

It all works OK for me.

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.

 

[Bassey]

It all works OK for me.

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:

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?

 

[StephenCrump]

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
1
2	Item Number Summary
3
4
5
6	451 - 454, 501 - 507
7	101, 102
8	201, 202
9
10
11
12	303 - 306
13	508 - 514
14	455 - 458
15
16
17
18	459 - 462, 515 - 521
19	103, 104

<tbody>
</tbody>

Formule​