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

 

[mole999]

this looks strange to me

sn = .Range("A3:A1003" & .Cells(Rows.Count, 1000).End(xlUp).Row)

the 1000 is less than the 1003 maybe make that 10000

 

[Bassey]

maybe make that 10000

Unfortunately this doesn't make a difference. Here the exemple of my sheet. Example Sheet.xlsm

I first run macro 'Uniquemultichannel' and then I run Macro All to polulate the sheet with formula's

 

[Bassey]

Anybody?

 

[StephenCrump]

There's a lot of code here, and it appears you don't really know where the errors are occurring. As a start, perhaps you could break down your testing into smaller pieces:

Test each of your UDFs independently, i.e. LookUpConcat, LookUpConcatNoC, LookUpConcatNoDup, and CondenseList. Do they work for the ranges and arguments that you want to use?

Once you know these are working, use the UDFs in a simple Sub, and check you can make them work.

Post back your progress, and I am happy to help further.

PS - It looks like you could replace Sub UniqueMultiChannel with an advanced filter. The macro recorder will help you get the correct syntax.

 

[StephenCrump]

I have now had a quick look at your workbook. All the Autofills work for me, i.e. they produce formulae in the right places. Whether they are correct is another matter, but the output looks meaningful. So I am not clear what the specific problem is. Are you perhaps wanting the unique list to update, and all the autofill formulae to update, any time there is change to Column A?

Excel 2010

	H	I	J	K	L	M	N	O	P	Q	R	S	T
2		channel count	Channel	Total weight	Count Per Item	Item	Count Per Item	Item	Count Per Item	Item	Count Per Item	Item	Item count Summary
3	Item CC, Item DD, Item EE	4	A1	2.50	2	Item CC	1	Item DD	1	Item EE			2*Item CC / Item DD / Item EE
4	Item CC	2	A2	1.30	2	Item CC							2*Item CC
5	Item GG	1	A3		1	Item GG							Item GG
6	Item BB, Item AA	11	A4	3.21	4	Item BB	7	Item AA					4*Item BB / 7*Item AA
7	Item EE	2	A5	1.40	2	Item EE							2*Item EE

<tbody>
</tbody>

Formule​

 

[Bassey]

I have now had a quick look at your workbook.

Hi Stephen, Thanx for having a look! My Issues are with the UDF's in column U and V. Especially column V.

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.

 

[Bassey]

Will try your debugging approach tonight as I'm at work now. But thanks for your effort!!

 

[Bassey]

The first thing I noticed now is that the result in the first three cells of column V should be blank as there are no Item numbers to lookup that relate to value A1, A2 and A3 (represented in Column J).

I entered some values to correspond with A1, A2 and A3 and now the autofill in column V will fill until the next blank apears after this the calculation fails again for the rest of the sheet.

Picture of the current situation is here
http://wikisend.com/download/235438/Schermafbeelding 2014-08-05 om 20.44.33.png

So could it be that some kind of error handling should be built into UDF:

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

Something like 'on error go to next cel' but then in real VBA??

Will continue to try more situations to find what might be wrong

 

[Jonmo1]

this looks strange to me
sn = .Range("A3:A1003" & .Cells(Rows.Count, 1000).End(xlUp).Row)

That looks strage to me as well.
Not sure if it's the problem, but it's definately "A" problem..

If your intention is for the .Cells(Rows.Count, 1000).End(xlUp).Row part to determine the end row of the range
So that it becomes A3:A10000 if the last row was 10000
Then it is definately wrong.
If .Cells(Rows.Count, 1000).End(xlUp).Row results in say 1000 as the Row #
Then it translates to
sn = .Range("A3:A1003" & 1000)
That's a concatenation there, so it becomes A1003 & 1000 = A10031000
sn = .Range("A3:A10031000)
which is just way off.


That line should be changed from
sn = .Range("A3:A1003" & .Cells(Rows.Count, 1000).End(xlUp).Row)
to
sn = .Range("A3:A" & .Cells(Rows.Count, 1000).End(xlUp).Row)