none
Calling Sub from a Function RRS feed

  • Question

  • I'm calling a sub within a function and need to pass an array's values from the function to the procedure.  However, I get a "'Run Time Error '13': Type Mismatch".  Any idea what is causing this?  Here is my code.

     

    Private Function SplitSigs2() As String
        Dim Sigs As Variant
        Dim Sigs2 As Variant
        Dim Sigs3 As Variant
        Dim NewSigs As Variant
        Dim Letters As Range
        Dim S As String
        Dim N As Long
        Dim M As Long
       
        Prompt3 = "Please select cell that contains the Comparison Groups"
        Title3 = "Comparison Groups"
       
        Set Letters = Application.InputBox( _
            Prompt:=Prompt3, _
            Title:=Title3, _
            Default:=ActiveCell.Address, _
            Type:=8) 'Type Range
            
            Sigs = Split(Letters, ":")
            NewSigs = Trim(Sigs(1))
                                      
        On Error Resume Next
            Sigs2 = Split(NewSigs, "/")
        On Error GoTo 0    
           
            For N = LBound(Sigs2) To UBound(Sigs2)
                For M = 1 To Len(Sigs2(N))
                 S = S & " " & Mid(Sigs2(N), M, 1)
                Next M
            Next N
            Sigs3 = Split(Mid(S, 2))
           
            Call LessSigTest
    End Function

    Sub LessSigTest()
        Dim Prompt, Prompt2, Title, Title2 As String
        Dim R As Range
        Dim Sel As Range
        Dim i As Long
        Dim RangeArray As Range
        Dim Cell As Object
        Dim X As Integer
        Dim Count As Integer
        Dim Target As String
        Dim Threshold As Variant
        Dim Sigs3 As Variant
       
        Prompt = "Select the range to be tested"
        Title = "Select a range"
        Prompt2 = "Enter a threshold (That is, how many sig letters must be present in order to highlight less than or greater than?)"
        Title2 = "Enter a threshold"
       
        On Error Resume Next
        Set RangeArray = Application.InputBox( _
            Prompt:=Prompt, _
            Title:=Title, _
            Default:=ActiveCell.Address, _
            Type:=8) ' Type Range
        On Error GoTo 0
     
        On Error Resume Next
        Set Threshold = Application.InputBox( _
            Prompt:=Prompt2, _
            Title:=Title2, _
            Default:=ActiveCell.Address, _
            Type:=1) ' Type Number
        On Error GoTo 0
       
        Application.ScreenUpdating = False
       
        Count = 0
        For Each R In RangeArray.Rows
            R.Select
            For Each Cell In Selection
                For i = LBound(Sigs3) To UBound(Sigs3)  This is where I get the error.  I need to pass in Sigs3 from the function above.

                 X = InStr(1, Cell.Value, i)
                 While X <> 0
                    Count = Count + 1
                    X = InStr(X + 1, Cell.Value, i)
                 Wend
                    Select Case Count
                        Case Is >= Threshold
                            Range("T54").Select 'Need to make this dynamic.
                            With Selection.Interior
                                .Pattern = xlSolid
                                .PatternColorIndex = xlAutomatic
                                .Color = 65535
                                .TintAndShade = 0
                                .PatternTintAndShade = 0
                            End With
                    End Select
                Next i
            Next Cell
                MsgBox Count
        Next R
    End Sub

    Monday, November 21, 2011 5:22 AM

Answers

  • Simply this -

    Call LessSigTest(sigs3)
    and
    Sub LessSigTest(sigs3)

    remove the now duplicate declaration Dim sigs3 As Variant in LessSigTest()

    I'd need to couble check but at a glance I think you could change

    Dim Sigs As Variant
    Dim Sigs2 As Variant
    Dim Sigs3 As Variant
    to
    Dim sigs() As String
    Dim sigs2() As String
    Dim sigs3() As String

    and
    Sub LessSigTest(sigs3)
    to
    Sub LessSigTest(sigs3() As String)
     In passing, suggest add "Option Explicit" (without quotes) to the top of hte module, that will force you to declare all variables (eg Prompt & Title (but suggest sTitle & SPrompt to avoid using duplicates of named arguments)

    No need to select, eg change
       For Each R In RangeArray.Rows
           R.Select
           For Each Cell In Selection
    to
           'R.Select
           For Each Cell In R

    and change
    With Selection.Interior
    to
    With R.Interior

    Peter Thornton
     <Looshsmoot> wrote in message news:5b28199b-b93c-4dcb-ad0b-6e1ebbcabae4@communitybridge.codeplex.com...

    I'm calling a sub within a function and need to pass an array's values from the function to the procedure. However, I get a "'Run Time Error '13': Type Mismatch". Any idea what is causing this? Here is my code.



    Private Function SplitSigs2() As String
    Dim Sigs As Variant
    Dim Sigs2 As Variant
    Dim Sigs3 As Variant
    Dim NewSigs As Variant
    Dim Letters As Range
    Dim S As String
    Dim N As Long
    Dim M As Long

    Prompt3 = "Please select cell that contains the Comparison Groups"
    Title3 = "Comparison Groups"

    Set Letters = Application.InputBox( _
    Prompt:=Prompt3, _
    Title:=Title3, _
    Default:=ActiveCell.Address, _
    Type:=8) 'Type Range

    Sigs = Split(Letters, ":")
    NewSigs = Trim(Sigs(1))

    On Error Resume Next
    Sigs2 = Split(NewSigs, "/")
    On Error GoTo 0

    For N = LBound(Sigs2) To UBound(Sigs2)
    For M = 1 To Len(Sigs2(N))
    S = S & " " & Mid(Sigs2(N), M, 1)
    Next M
    Next N
    Sigs3 = Split(Mid(S, 2))

    Call LessSigTest
    End Function

    Sub LessSigTest()
    Dim Prompt, Prompt2, Title, Title2 As String
    Dim R As Range
    Dim Sel As Range
    Dim i As Long
    Dim RangeArray As Range
    Dim Cell As Object
    Dim X As Integer
    Dim Count As Integer
    Dim Target As String
    Dim Threshold As Variant
    Dim Sigs3 As Variant

    Prompt = "Select the range to be tested"
    Title = "Select a range"
    Prompt2 = "Enter a threshold (That is, how many sig letters must be present in order to highlight less than or greater than?)"
    Title2 = "Enter a threshold"

    On Error Resume Next
    Set RangeArray = Application.InputBox( _
    Prompt:=Prompt, _
    Title:=Title, _
    Default:=ActiveCell.Address, _
    Type:=8) ' Type Range
    On Error GoTo 0

    On Error Resume Next
    Set Threshold = Application.InputBox( _
    Prompt:=Prompt2, _
    Title:=Title2, _
    Default:=ActiveCell.Address, _
    Type:=1) ' Type Number
    On Error GoTo 0

    Application.ScreenUpdating = False

    Count = 0
    For Each R In RangeArray.Rows
    R.Select
    For Each Cell In Selection
    For i = LBound(Sigs3) To UBound(Sigs3) This is where I get the error. I need to pass in Sigs3 from the function above.

    X = InStr(1, Cell.Value, i)
    While X <> 0
    Count = Count + 1
    X = InStr(X + 1, Cell.Value, i)
    Wend
    Select Case Count
    Case Is >= Threshold
    Range("T54").Select 'Need to make this dynamic.
    With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
    End With
    End Select
    Next i
    Next Cell
    MsgBox Count
    Next R
    End Sub

    • Marked as answer by Looshsmoot Monday, November 21, 2011 5:44 PM
    Monday, November 21, 2011 8:23 AM
    Moderator
  • On Mon, 21 Nov 2011 05:22:07 +0000, Looshsmoot wrote:
     
    >I'm calling a sub within a function and need to pass an array's values from the function to the procedure.  However, I get a "'Run Time Error '13': Type Mismatch".  Any idea what is causing this?
     
    You never specify that you are passing Sigs3 to the Sub.  Your Sub has no arguments, and your Call statement doesn't mention Sigs3.
     
    Something like the following is one way to pass an argument from one procedure to another:
     
    =====================
    Function foo() As Variant
        Dim Sigs3 As Variant
        Sigs3 = Array(1, 2, 3, 4, 5)
        bar Sigs3
        foo = Sigs3
    End Function
     
    Sub bar(Sigs3)
        Dim i As Long
        Dim t As Variant
    t = Sigs3
    For i = UBound(t) To LBound(t) Step -1
        Sigs3(LBound(t) + UBound(t) - i) = t(i)
    Next i
     
    End Sub
    ==========================
     
    And there is no requirement that the variable have the same name in both procedures.
     
    You could also declare Sigs3 to be a Public variable.  Note that your Sub will be less flexible.
     
     
    ===============================
    Option Explicit
    Public Sigs3 As Variant
     
    Function foo() As Variant
        Sigs3 = Array(1, 2, 3, 4, 5)
        Call bar
        foo = Sigs3
    End Function
     
    Sub bar()
        Dim i As Long
        Dim t As Variant
    t = Sigs3
    For i = UBound(t) To LBound(t) Step -1
        Sigs3(LBound(t) + UBound(t) - i) = t(i)
    Next i
    End Sub
    ================================
     

    Ron
    • Marked as answer by Looshsmoot Monday, November 21, 2011 8:57 PM
    Monday, November 21, 2011 11:24 AM
  • In your first routine none of Prompt, Title, Prompt2, Title2, Prompt3, Title3 are declared at all

    In your 2nd routine you declared the following
    Dim Prompt, Prompt2, Title, Title2 As String
    in passing, only Title2  is declared as a string, the others are variants

    There are no duplicate declarations. In your first routine Prompt3, Title3 are not declared but should be.

    If you are now getting a duplicate declaration concerning those variables you must have added duplicates since your OP.

    BTW, did you remove the Sigs3 declaration in your callee routine as I explained.

    Peter Thornton

    • Marked as answer by Looshsmoot Monday, November 21, 2011 6:29 PM
    Monday, November 21, 2011 5:52 PM
    Moderator
  • OK, I understand a lot more than before but not all. Run the following on an empty sheet -

    Sub test()
    ActiveSheet.UsedRange.Clear
    Range("A1:C1") = Array(0.9, "EHIJ", 0.6)
    Range("A2:C2") = Array(0.1, "BD", "jmno")
    Range("H1") = "Comparison Groups: BCDEFGHIJ/KL/MNO"
            Dim pos As Long
         Dim i As Long, j As Long
         Dim sCompGrp As String, s As String, sResult As String
         Dim rng As Range
         Dim rngRow As Range
         Dim cel As Range
         Dim arrCountRow() As Long
         Dim arrCountAll() As Long
            sCompGrp = Range("H1")
         pos = InStr(1, sCompGrp, ":") + 1
         sCompGrp = Mid$(sCompGrp, pos, Len(sCompGrp))
         sCompGrp = Replace(sCompGrp, "/", "")
         sCompGrp = Replace(sCompGrp, " ", "")
         sCompGrp = UCase(sCompGrp)
            If Len(sCompGrp) = 0 Then
                 MsgBox "Len(sCompGrp) = 0"
                 Exit Sub
         End If
            ReDim arrCountAll(1 To Len(sCompGrp))
            Set rng = Range("A1:C2")
            For Each rngRow In rng.Rows
                 ReDim arrCountRow(1 To Len(sCompGrp))
                 For Each cel In rngRow.Cells
                         If VarType(cel.Value) = vbString Then
                                 s = UCase(cel.Text)
                                 For i = 1 To Len(s)
                                         For j = 1 To Len(sCompGrp)
                                                 If Mid$(s, i, 1) = Mid$(sCompGrp, j, 1) Then
                                                         arrCountAll(j) = arrCountAll(j) + 1
                                                         arrCountRow(j) = arrCountRow(j) + 1
                                                 End If
                                         Next
                                 Next
                         End If
                 Next
                 sResult = "'"
                 For i = 1 To UBound(arrCountRow)
                         sResult = sResult & arrCountRow(i)
                 Next
                 rngRow.Offset(0, rngRow.Columns.Count + 1).Resize(1, 1) = sResult
         Next
            sResult = "'"     ' apostrophe to preserve leading zeros
         For i = 1 To UBound(arrCountAll)
                 sResult = sResult & arrCountAll(i)
         Next
         rng.Offset(rng.Rows.Count + 1, rng.Columns.Count + 1).Resize(1, 1) =
    sResult
    
    End Sub

    I don't know how you want to diusplay the result, eg "'00010011100000" or individually in multiple cells. Also not sure if you want the result on a per row basis or a total for all rows, the example returns both. Not sure about your threshold value but it should be easy enough for you to loop either or both the count arrays.

    Hopefully you can adapt to suit but post back otherwise. You may well want to break it up into separate routines, eg one to ask user for the input ranges and another to process the data.

    Peter Thornton

    • Marked as answer by Looshsmoot Monday, December 5, 2011 12:33 AM
    Wednesday, November 23, 2011 10:16 AM
    Moderator

All replies

  • Simply this -

    Call LessSigTest(sigs3)
    and
    Sub LessSigTest(sigs3)

    remove the now duplicate declaration Dim sigs3 As Variant in LessSigTest()

    I'd need to couble check but at a glance I think you could change

    Dim Sigs As Variant
    Dim Sigs2 As Variant
    Dim Sigs3 As Variant
    to
    Dim sigs() As String
    Dim sigs2() As String
    Dim sigs3() As String

    and
    Sub LessSigTest(sigs3)
    to
    Sub LessSigTest(sigs3() As String)
     In passing, suggest add "Option Explicit" (without quotes) to the top of hte module, that will force you to declare all variables (eg Prompt & Title (but suggest sTitle & SPrompt to avoid using duplicates of named arguments)

    No need to select, eg change
       For Each R In RangeArray.Rows
           R.Select
           For Each Cell In Selection
    to
           'R.Select
           For Each Cell In R

    and change
    With Selection.Interior
    to
    With R.Interior

    Peter Thornton
     <Looshsmoot> wrote in message news:5b28199b-b93c-4dcb-ad0b-6e1ebbcabae4@communitybridge.codeplex.com...

    I'm calling a sub within a function and need to pass an array's values from the function to the procedure. However, I get a "'Run Time Error '13': Type Mismatch". Any idea what is causing this? Here is my code.



    Private Function SplitSigs2() As String
    Dim Sigs As Variant
    Dim Sigs2 As Variant
    Dim Sigs3 As Variant
    Dim NewSigs As Variant
    Dim Letters As Range
    Dim S As String
    Dim N As Long
    Dim M As Long

    Prompt3 = "Please select cell that contains the Comparison Groups"
    Title3 = "Comparison Groups"

    Set Letters = Application.InputBox( _
    Prompt:=Prompt3, _
    Title:=Title3, _
    Default:=ActiveCell.Address, _
    Type:=8) 'Type Range

    Sigs = Split(Letters, ":")
    NewSigs = Trim(Sigs(1))

    On Error Resume Next
    Sigs2 = Split(NewSigs, "/")
    On Error GoTo 0

    For N = LBound(Sigs2) To UBound(Sigs2)
    For M = 1 To Len(Sigs2(N))
    S = S & " " & Mid(Sigs2(N), M, 1)
    Next M
    Next N
    Sigs3 = Split(Mid(S, 2))

    Call LessSigTest
    End Function

    Sub LessSigTest()
    Dim Prompt, Prompt2, Title, Title2 As String
    Dim R As Range
    Dim Sel As Range
    Dim i As Long
    Dim RangeArray As Range
    Dim Cell As Object
    Dim X As Integer
    Dim Count As Integer
    Dim Target As String
    Dim Threshold As Variant
    Dim Sigs3 As Variant

    Prompt = "Select the range to be tested"
    Title = "Select a range"
    Prompt2 = "Enter a threshold (That is, how many sig letters must be present in order to highlight less than or greater than?)"
    Title2 = "Enter a threshold"

    On Error Resume Next
    Set RangeArray = Application.InputBox( _
    Prompt:=Prompt, _
    Title:=Title, _
    Default:=ActiveCell.Address, _
    Type:=8) ' Type Range
    On Error GoTo 0

    On Error Resume Next
    Set Threshold = Application.InputBox( _
    Prompt:=Prompt2, _
    Title:=Title2, _
    Default:=ActiveCell.Address, _
    Type:=1) ' Type Number
    On Error GoTo 0

    Application.ScreenUpdating = False

    Count = 0
    For Each R In RangeArray.Rows
    R.Select
    For Each Cell In Selection
    For i = LBound(Sigs3) To UBound(Sigs3) This is where I get the error. I need to pass in Sigs3 from the function above.

    X = InStr(1, Cell.Value, i)
    While X <> 0
    Count = Count + 1
    X = InStr(X + 1, Cell.Value, i)
    Wend
    Select Case Count
    Case Is >= Threshold
    Range("T54").Select 'Need to make this dynamic.
    With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
    End With
    End Select
    Next i
    Next Cell
    MsgBox Count
    Next R
    End Sub

    • Marked as answer by Looshsmoot Monday, November 21, 2011 5:44 PM
    Monday, November 21, 2011 8:23 AM
    Moderator
  • On Mon, 21 Nov 2011 05:22:07 +0000, Looshsmoot wrote:
     
    >I'm calling a sub within a function and need to pass an array's values from the function to the procedure.  However, I get a "'Run Time Error '13': Type Mismatch".  Any idea what is causing this?
     
    You never specify that you are passing Sigs3 to the Sub.  Your Sub has no arguments, and your Call statement doesn't mention Sigs3.
     
    Something like the following is one way to pass an argument from one procedure to another:
     
    =====================
    Function foo() As Variant
        Dim Sigs3 As Variant
        Sigs3 = Array(1, 2, 3, 4, 5)
        bar Sigs3
        foo = Sigs3
    End Function
     
    Sub bar(Sigs3)
        Dim i As Long
        Dim t As Variant
    t = Sigs3
    For i = UBound(t) To LBound(t) Step -1
        Sigs3(LBound(t) + UBound(t) - i) = t(i)
    Next i
     
    End Sub
    ==========================
     
    And there is no requirement that the variable have the same name in both procedures.
     
    You could also declare Sigs3 to be a Public variable.  Note that your Sub will be less flexible.
     
     
    ===============================
    Option Explicit
    Public Sigs3 As Variant
     
    Function foo() As Variant
        Sigs3 = Array(1, 2, 3, 4, 5)
        Call bar
        foo = Sigs3
    End Function
     
    Sub bar()
        Dim i As Long
        Dim t As Variant
    t = Sigs3
    For i = UBound(t) To LBound(t) Step -1
        Sigs3(LBound(t) + UBound(t) - i) = t(i)
    Next i
    End Sub
    ================================
     

    Ron
    • Marked as answer by Looshsmoot Monday, November 21, 2011 8:57 PM
    Monday, November 21, 2011 11:24 AM
  • I used Option Explicit, but it is telling me I have a duplicate declaration.  My variable names are:

    Prompt, Title, Prompt2, Title2, Prompt3, Title3

    So why does it say they are duplicated?

    Monday, November 21, 2011 4:56 PM
  • Thanks for you input.  Very Helpful!
    Monday, November 21, 2011 5:44 PM
  • In your first routine none of Prompt, Title, Prompt2, Title2, Prompt3, Title3 are declared at all

    In your 2nd routine you declared the following
    Dim Prompt, Prompt2, Title, Title2 As String
    in passing, only Title2  is declared as a string, the others are variants

    There are no duplicate declarations. In your first routine Prompt3, Title3 are not declared but should be.

    If you are now getting a duplicate declaration concerning those variables you must have added duplicates since your OP.

    BTW, did you remove the Sigs3 declaration in your callee routine as I explained.

    Peter Thornton

    • Marked as answer by Looshsmoot Monday, November 21, 2011 6:29 PM
    Monday, November 21, 2011 5:52 PM
    Moderator
  • I see.  Thank you!.

    Yes, I removed the Sigs3 declaration in the callee. 

    Monday, November 21, 2011 6:29 PM
  • Thanks so much for your help.  Everything seems to be working, except the the bolded code below doesn't seem to be counting the number of occurances of each letter in the array (B, C, D...etc.).  It is definitely counting something, but I can't tell what.  For instance, if the array's elements are B through O, and if RangeArray consists of 1 row, 3 cells that contain 9%, EHIJ, 6%, respectively, the count of each element return: 5, 1, 4, 6, 5, 1, 5, 1, 2, 4, 1, 0, 0, 0.  I would expect it to be: 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0. 

    How do I make it count the strings (letters) in the array?

    Sub LessSigTest(Sigs3() As String)
        Dim Prompt As String
        Dim Prompt2 As String
        Dim Title As String
        Dim Title2 As String
        Dim R As Range
        Dim Sel As Range
        Dim i As Long
        Dim RangeArray As Range
        Dim Cell As Object
        Dim X As Integer
        Dim Count As Integer
        Dim Target As String
        Dim Threshold As Variant
           
        Prompt = "Select the range to be tested"
        Title = "Select a range"
        Prompt2 = "Enter a threshold (That is, how many sig letters must be present in order to highlight less than or greater than?)"
        Title2 = "Enter a threshold"
       
        On Error Resume Next
        Set RangeArray = Application.InputBox( _
            Prompt:=Prompt, _
            Title:=Title, _
            Default:=ActiveCell.Address, _
            Type:=8) ' Type Range
        On Error GoTo 0
     
        On Error Resume Next
        Set Threshold = Application.InputBox( _
            Prompt:=Prompt2, _
            Title:=Title2, _
            Default:=ActiveCell.Address, _
            Type:=1) ' Type Number
        On Error GoTo 0
       
        Application.ScreenUpdating = False
       
        For i = LBound(Sigs3) To UBound(Sigs3) 'Where Sigs3's elements are the letters in user's selection.
            For Each R In RangeArray.Rows
                R.Select
                    Count = 0
                For Each Cell In Selection
                    X = InStr(1, Cell.Value, i, vbBinaryCompare)
                    While X <> 0
                        Count = Count + 1
                        X = InStr(X + 1, Cell.Value, i, vbBinaryCompare)
                    Wend
                Next Cell
            Next R
            MsgBox Count, vbOKOnly, "Count"
        Next i
    End Sub

    Monday, November 21, 2011 7:02 PM
  • Ron,

    Thanks for the reply.  I'm very new to VBA (and programming in general).  Can you explain what this is doing?

    t = Sigs3
    For i = UBound(t) To LBound(t) Step -1
    Sigs3(LBound(t) + UBound(t) - i) = t(i)
    Next i
    Thanks,
    Lucian
    Monday, November 21, 2011 8:07 PM
  • It doesn't matter what it is doing.  It was a response to your query about how to pass an argument to a Sub.  The procedure itself could be anything.

    This particular procedure just reverses the array in the variable passed to it.


    Ron
    Monday, November 21, 2011 8:33 PM
  • Got it.  Thank you.

    Monday, November 21, 2011 8:57 PM
  • Afraid I don't follow the data, seems you are saying cells A1:C1 contain 9%, EHIJ, 6%, but I have no idea how that translates to that array. Try explaining a different way, clearly describe sample data in cells, and how that data should be processed.

    Peter Thornton

    Monday, November 21, 2011 9:44 PM
    Moderator
  • The array (Sigs3) consists only of letters only.  After the array is established, the user selelcts the range of cells (RangeArray) of where to look and count.  In this scenario the user selects a range of 3 cells (establishing the RangeArray Range), the first cell containing 9%, the second EHIJ, and the third 6%.  The if the Sigs3 array contains EHIJ, it should count 1 E, 1 H, 1 I, and 1 J, and should ignore the other cells.  Does that make sense? 

    Monday, November 21, 2011 10:45 PM
  • Afraid I'm even more confused. There's nothing in your code that I can relate to an attempt to return something like "1 E, 1 H, 1 I, and 1 J" if "the Sigs3 array contains EHIJ".

    This is your count -

    X = InStr(1, Cell.Value, i, vbBinaryCompare)

    that will increment the counter if every time the value of i exits in the cell.

    It would be easier if you give an example of data cells and explain the objective. What might be in "Comparison Groups" and "range to be tested" and "threshold". Given those inputs what would you expect to be returned and why.

    Peter Thornton

    Tuesday, November 22, 2011 8:43 AM
    Moderator
  • Addressing the first part of your question:  I want this: For i = LBound(Sigs3) To UBound(Sigs3) 'Where Sigs3's elements are the letters in user's selection.
    For Each R In RangeArray.Rows
    R.Select
    Count = 0
    For Each Cell In Selection
    X = InStr(1, Cell.Value, i, vbBinaryCompare)
    While X <> 0
    Count = Count + 1
    X = InStr(X + 1, Cell.Value, i, vbBinaryCompare)
    Wend
    Next Cell
    Next R
    MsgBox Count, vbOKOnly, "Count"
    Next i
     to count not the occurances of i, but the occurances of each element in Sigs3. 

    Example:

    1. The user selects a cell in Excel via input box.  This cell contains this: "Comparison Groups: BCDEFGHIJ/KL/MNO".

    2. The user selects a range (i.e., "Range to be Tested") in Excel.  This is called RangeArray. Let's say the range the user selects is ("A1:C2").  Contents the cells are: A1=9%, B1=EHIJ, C1=6%; A2=1%, B2=BD, C2=0%.

    3. My SplitSigs2 Function takes the contents of the comparison groups cell selected in #1 above, separates the "BCDEFGHIJ/KL/MNO" from "comparison groups:", and creates an array (Sigs3) that consists of just the letters (B-O), where each element is a single letter, B, C, D, etc.  I have verified that this function works correctly. 

    4. Next (and here is the part where I have trouble), I want the code to go row-by-row in the RangeArray and count the number of times each letter occurs.  For example, it would first count the number of Bs (the first element in Sigs3) in row A1:C1, then the number of Cs (the second element in Sigs3) in row A1:C1, then the number of Ds in A1:C1, etc.  Then it goes to the next row (A2:C2) and repeats the process - counts the As, Bs, etc.

    So in this example, in the first row (A1:C1), I would expect a count of 0 for every letter except EHIJ, each of which would have a count of 1 (since there is one E in row A1:C1, and one H, one I, one J).  In the next row (A2:C2) I would expect a count of one for B and one for D, and 0 for every other letter.

    Eventually (I don't have it yet), I will have code that says, "If there are more Bs, for example, than the threshold then highlight a certain cell yellow."  So if the user tells the input box that the threshold is 4, then if there are 4 or more Bs in any given row, it would highlight a certain cell yellow in that row.  It would do this for each letter in each row.

    I hope this makes sense.  If not, let me know. Thanks again.

    Lucian

     

    Tuesday, November 22, 2011 9:41 PM
  • OK, I understand a lot more than before but not all. Run the following on an empty sheet -

    Sub test()
    ActiveSheet.UsedRange.Clear
    Range("A1:C1") = Array(0.9, "EHIJ", 0.6)
    Range("A2:C2") = Array(0.1, "BD", "jmno")
    Range("H1") = "Comparison Groups: BCDEFGHIJ/KL/MNO"
            Dim pos As Long
         Dim i As Long, j As Long
         Dim sCompGrp As String, s As String, sResult As String
         Dim rng As Range
         Dim rngRow As Range
         Dim cel As Range
         Dim arrCountRow() As Long
         Dim arrCountAll() As Long
            sCompGrp = Range("H1")
         pos = InStr(1, sCompGrp, ":") + 1
         sCompGrp = Mid$(sCompGrp, pos, Len(sCompGrp))
         sCompGrp = Replace(sCompGrp, "/", "")
         sCompGrp = Replace(sCompGrp, " ", "")
         sCompGrp = UCase(sCompGrp)
            If Len(sCompGrp) = 0 Then
                 MsgBox "Len(sCompGrp) = 0"
                 Exit Sub
         End If
            ReDim arrCountAll(1 To Len(sCompGrp))
            Set rng = Range("A1:C2")
            For Each rngRow In rng.Rows
                 ReDim arrCountRow(1 To Len(sCompGrp))
                 For Each cel In rngRow.Cells
                         If VarType(cel.Value) = vbString Then
                                 s = UCase(cel.Text)
                                 For i = 1 To Len(s)
                                         For j = 1 To Len(sCompGrp)
                                                 If Mid$(s, i, 1) = Mid$(sCompGrp, j, 1) Then
                                                         arrCountAll(j) = arrCountAll(j) + 1
                                                         arrCountRow(j) = arrCountRow(j) + 1
                                                 End If
                                         Next
                                 Next
                         End If
                 Next
                 sResult = "'"
                 For i = 1 To UBound(arrCountRow)
                         sResult = sResult & arrCountRow(i)
                 Next
                 rngRow.Offset(0, rngRow.Columns.Count + 1).Resize(1, 1) = sResult
         Next
            sResult = "'"     ' apostrophe to preserve leading zeros
         For i = 1 To UBound(arrCountAll)
                 sResult = sResult & arrCountAll(i)
         Next
         rng.Offset(rng.Rows.Count + 1, rng.Columns.Count + 1).Resize(1, 1) =
    sResult
    
    End Sub

    I don't know how you want to diusplay the result, eg "'00010011100000" or individually in multiple cells. Also not sure if you want the result on a per row basis or a total for all rows, the example returns both. Not sure about your threshold value but it should be easy enough for you to loop either or both the count arrays.

    Hopefully you can adapt to suit but post back otherwise. You may well want to break it up into separate routines, eg one to ask user for the input ranges and another to process the data.

    Peter Thornton

    • Marked as answer by Looshsmoot Monday, December 5, 2011 12:33 AM
    Wednesday, November 23, 2011 10:16 AM
    Moderator
  • Thank you.  This is perfect.  I have been able to use a slight modification of this to achieve my objective.
    Monday, December 5, 2011 12:30 AM
  • Peter, I have a similar procedure to the one above, but this one is intended to count the occurances of a 2-digit capital letter/number combo: "A2", "B2", "C2", through "Z2".  The code below appears to be doing what I need, until it gets to the xarrCountRow(K) part.  If you step through the code with F8 and select range B1:D1 via the input box, you'll notice when you get to xarrCountRow(K) it skips to End Sub.  However, if you put an apostrophe in front of xarrCountRow(K), the message box demonstrates that the code appears to be working up to that point.  How do I make the code to perform the count?

     

    Sub SigCountLessThan7()
         Dim i As Long, j As Long, K As Long
         Dim xCompGrp(1 To 26) As String
         Dim s As Variant
         Dim xrng As Range
         Dim xrngRow As Range
         Dim xCel As Range
         Dim xarrCountRow() As Long
         Dim Threshold As Variant

         Range("B1:D1") = Array("A2", "B2", "C2", "D2")
        
         xCompGrp(1) = "A2"
         xCompGrp(2) = "B2"
         xCompGrp(3) = "C2"
         xCompGrp(4) = "D2"
         xCompGrp(5) = "E2"
         xCompGrp(6) = "F2"
         xCompGrp(7) = "G2"
         xCompGrp(8) = "H2"
         xCompGrp(9) = "I2"
         xCompGrp(10) = "J2"
         xCompGrp(11) = "K2"
         xCompGrp(12) = "L2"
         xCompGrp(13) = "M2"
         xCompGrp(14) = "N2"
         xCompGrp(15) = "O2"
         xCompGrp(16) = "P2"
         xCompGrp(17) = "Q2"
         xCompGrp(18) = "R2"
         xCompGrp(19) = "S2"
         xCompGrp(20) = "T2"
         xCompGrp(21) = "U2"
         xCompGrp(22) = "V2"
         xCompGrp(23) = "W2"
         xCompGrp(24) = "X2"
         xCompGrp(25) = "Y2"
         xCompGrp(26) = "Z2"
             
         'On Error GoTo Cancel
         'Threshold = Application.InputBox(Prompt:="What is your threshold?", _
                            Title:="Threshold", _
                            Type:=1)
        
           
            On Error GoTo Cancel
            Set xrng = Application.InputBox(Prompt:="Select the data range.", _
                                            Title:="Select Data", _
                                            Type:=8)
                                           
            Application.ScreenUpdating = False
           
            For Each xrngRow In xrng.Rows
            ReDim xarrCountRow(1 To 26)
                For Each xCel In xrngRow.Cells
                    If VarType(xCel.Value) = vbString Then
                        s = xCel.Text 's is a string here.
                            For i = 1 To Len(s)
                                For j = LBound(xCompGrp) To UBound(xCompGrp)
                                    If Mid$(s, i, 2) = xCompGrp(j) Then
                                        MsgBox xCompGrp(j)
                                        xarrCountRow(K) = xarrCountRow(K) + 1
                                    End If
                                Next
                            Next
                    End If
                Next
                sResult = "'"
                 For i = 1 To UBound(xarrCountRow)
                         sResult = sResult & xarrCountRow(i)
                 Next
                 Range("F5") = sResult
            Next
           
    Cancel:
    End Sub

    Thursday, December 15, 2011 7:37 PM
  • Think you need to change
    xarrCountRow(K) = xarrCountRow(K) + 1
    to
    xarrCountRow(j) = xarrCountRow(j) + 1

    Also, if processing multiple rows move the loop that build sResult after the outer loop, ie after the 2nd Next.

    Why not populate the xCompGrp array like this (3 lines instead of 26)

    For i = 1 To 26
         xCompGrp(i) = Chr$(64 + i) & "2"
    Next

    Suggest head your module Option Explicit

    Peter Thornton

    Thursday, December 15, 2011 11:02 PM
    Moderator
  • I've had trouble replying, so apologize if you get this multiple times:

    Thanks for your suggestions. I'll definitely think to use Option Explicit. Also, thanks for the loop to fill the xCompGrp (I knew there had to be a way!).

    Subsequent to my last post, I decided to take the following direction. However, I want it to ignore (i.e. not count) lower case letter+2 (e.g. a2). Note: I'm putting the results 3 rows below brng, but that is for testing purposes only.

    Can you help me make it case sensitive? So if you highlight Range A2:C2, it would count 3, not 4.

    Sub Lke()

        Dim brng As Range
        Dim brngRow As Range
        Dim bCel As Range
        Dim barrCountRow As Long

        Range("A1:H1") = Array("A2", "B2", "", "D2", "", "F2", "G2", "H2")
        Range("A2:C2") = Array("F2", "G2", "a2N2")
       
        On Error GoTo Cancel
            Set brng = Application.InputBox(Prompt:="Select the data range.", _
                                            Title:="Select Data", _
                                            Type:=8)
                                           
            Application.ScreenUpdating = False
           
            For Each brngRow In brng.Rows
            barrCountRow = 0
                For Each bCel In brngRow.Cells
                    If VarType(bCel.Value) = vbString Then
                        s = bCel.Text
                            For i = 1 To Len(s)
                                    If Mid$(s, i, 2) Like "?2" Then
                                        barrCountRow = barrCountRow + 1
                                    End If
                            Next
                    End If
                    bCel.Offset(brng.Rows.Count + 3, 0) = barrCountRow
                Next
            Next
           
    Cancel:
    End Sub

    By the way, what is the $ for in Chr$(64+i)?

     

    Friday, December 16, 2011 12:19 AM
  • Lots of ways, here are just two

    For i = 2 To Len(s)
       If Mid$(s, i, 1) = "2" Then
           x = Asc(Mid$(s, i - 1, 1))
           If x >= 65 And x <= (64 + 26) Then
               barrCountRow = barrCountRow + 1
           End If
       End If
    Next

    Dim bArr() As Byte ' declare this byte array up top
    For i = 2 To UBound(bArr) Step 2
       If bArr(i) = 50 And bArr(i + 1) = 0 Then
           If bArr(i - 2) >= 65 And bArr(i - 2) <= (64 + 26) And bArr(i - 1) = 0 Then
               barrCountRow = barrCountRow + 1
           End If
       End If
    Next

    The byte array approach although it looks like more work is extremely efficient.

    Re Chr / Chr$, the $ in some string functions internally forces the return value as a string, rather than coercing the result from a variant. Lookup Chr/$ in object browser, look at the function return type. In theory with the $ is more efficient though in practice not likely to notice the difference unless calling it millions of times

    Peter Thornton

    Friday, December 16, 2011 9:34 AM
    Moderator