Vba list items separated by comma when conditions met

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. Windows
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
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Hi, Kelly,
How's this:
Code:
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
 
Upvote 0
Code:
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
 
Upvote 0
Very sweet.


Both codes are cute.

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

Thanks again
 
Upvote 0


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

Code:
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
 
Upvote 0
How do I put "and" between the last two instead of comma?
 
Upvote 0
Code:
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
 
Upvote 0
Cool cool. I knew you can pull me me out again.

I am very grateful
 
Upvote 0
Also try the following

Code:
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
 
Upvote 0
Also try the following

Code:
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 :laugh:
 
Upvote 0

Forum statistics

Threads
1,223,275
Messages
6,171,126
Members
452,381
Latest member
Nova88

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