Vba list items separated by comma when conditions met

[kelly mort]

I have a table that I have names in column A then inside column G are numbers.

Column A is in range A17:A25 then G is also G17:G25.

So in cell A16, I want to get all names that have values greater than 10 in column G.

These names should be separated by comma. And if only one exists then no comma.

Also if none exists, we blank A16.

I am stacked .

I need help.

Thanks

 

[NewOrderFac33]

Hi, Kelly,
How's this:

Sub Plus10Names()
    
    Dim MyString As String
    Dim MyCell As Range
    Dim MyCount As Long
    
    MyString = ""
    MyCount = 0
    
    For Each MyCell In Sheets("Sheet1").Range("A17:A25")
        If MyCell.Offset(0, 6) > 10 Then
            If Len(MyString) = 0 Then
                MyString = MyCell.Formula
            Else
                MyString = MyString & "," & MyCell.Formula
            End If
            MyCount = MyCount + 1
        End If
    Next
    
    If MyCount > 0 Then
        Sheets("Sheet1").Range("A16").Formula = MyString
    Else
        Sheets("Sheet1").Range("A16").ClearContents
    End If
    
End Sub

Regards
Pete

 

[JLGWhiz]

Sub names()
Dim c As Range, nm As String
With ActiveSheet
    .Range("A16").ClearContents
    For Each c In .Range("A17:A25")
        If c.Offset(, 6).Value > 10 Then
            If nm = "" Then
                nm = c.Value
            Else
                nm = nm & ", " & c.Value
            End If
        End If
    Next
    .Range("A16") = nm
End With
End Sub

 

[kelly mort]

Very sweet.


Both codes are cute.

I am running series of tests to select the fastest and smoother.

Thanks again

 

[kelly mort]

I modified your code like this then I got stacked again. Can you pull me out again?

Sub names()
Dim c As Range, nm As String, nm1 As String, OutPut As String 
With ActiveSheet
    .Range("A16").ClearContents
    For Each c In .Range("A17:A25")
        

Select Case c.Offset(, 6).Value 
        Case Is >10
            If nm = "" Then
                nm = c.Value
            Else
                nm = nm & ", " & c.Value
            End If

            Case Is <5
                         If nm1 = "" Then
                nm1 = c.Value
            Else
                nm1 = nm1 & ", " & c.Value
            End If
        End Select 
    Next
    'This is where I am stacked at:
     'OutPut =
End With
End Sub

I want the out to be a message box that will work like this :
1. If both nm and nm1 are blank say none
2. If only nm blank say low
3. If only nm1 blank say high
4. If both not blank say both



I need tech support

 

[kelly mort]

How do I put "and" between the last two instead of comma?

 

[JLGWhiz]

Sub names()
Dim c As Range, nm As String, nm1 As String, OutPut As String
With ActiveSheet
    .Range("A16").ClearContents
    For Each c In .Range("A17:A25")
        Select Case c.Offset(, 6).Value
            Case Is > 10
                If nm = "" Then
                    nm = c.Value
                Else
                    nm = nm & ", " & c.Value
                End If
            Case Is < 5
                If nm1 = "" Then
                    nm1 = c.Value
                Else
                    nm1 = nm1 & ", " & c.Value
                End If
        End Select
    Next
    Range("A16") = Left(nm, InStrRev(nm, ",") - 1) & " and " & Mid(nm, InStrRev(nm, ",") + 1)
    If nm = "" And nm1 = "" Then
        MsgBox "None"
    ElseIf nm = "" And nm1 <> "" Then
        MsgBox "Low"
    ElseIf nm <> "" And nm1 = "" Then
        MsgBox "High"
    ElseIf nm <> "" And nm1 <> "" Then
    MsgBox "Both"
    End If
End With
End Sub

 

[kelly mort]

Cool cool. I knew you can pull me me out again.

I am very grateful

 

[DanteAmor]

Also try the following

Sub List_Names()
    For Each v In Range("A17:A25")
        If v.Offset(0, 6).Value > 10 Then cad1 = cad1 & v.Value & ", "
        If v.Offset(0, 6).Value < 5 Then cad2 = cad2 & v.Value & ", "
    Next
    On Error Resume Next
    cad1 = Left(cad1, Len(cad1) - 2)
    cad2 = Left(cad2, Len(cad2) - 2)
    cad1 = WorksheetFunction.Replace(cad1, InStrRev(cad1, ","), 1, " y")
    cad2 = WorksheetFunction.Replace(cad2, InStrRev(cad2, ","), 1, " y")
    Range("A16").Value = cad1
    
    If cad1 = "" And cad2 = "" Then wmes = "None"
    If cad1 = "" And cad2 <> "" Then wmes = "low"
    If cad1 <> "" And cad2 = "" Then wmes = "high"
    If cad1 <> "" And cad2 <> "" Then wmes = "both"
    MsgBox wmes
End Sub

 

[kelly mort]

Also try the following

Sub List_Names()
    For Each v In Range("A17:A25")
        If v.Offset(0, 6).Value > 10 Then cad1 = cad1 & v.Value & ", "
        If v.Offset(0, 6).Value < 5 Then cad2 = cad2 & v.Value & ", "
    Next
    On Error Resume Next
    cad1 = Left(cad1, Len(cad1) - 2)
    cad2 = Left(cad2, Len(cad2) - 2)
    cad1 = WorksheetFunction.Replace(cad1, InStrRev(cad1, ","), 1, " y")
    cad2 = WorksheetFunction.Replace(cad2, InStrRev(cad2, ","), 1, " y")
    Range("A16").Value = cad1
    
    If cad1 = "" And cad2 = "" Then wmes = "None"
    If cad1 = "" And cad2 <> "" Then wmes = "low"
    If cad1 <> "" And cad2 = "" Then wmes = "high"
    If cad1 <> "" And cad2 <> "" Then wmes = "both"
    MsgBox wmes
End Sub

Great ! ! !

I can't wait to get smarter tooo