none
How to return multiple values vertically of a lookup using VBA? RRS feed

  • Question

  • I've got an excel file in which there is a table with two columns Name & Age. Now some of the Name have multiple values in Age column. How do I get all of the values (each value in a separate row) in one go using VBA

    I can do something like below without VBA but I have to drag it down to fill in the other values

    =INDEX($C$3:$C$12, SMALL(IF(($F$3=$B$3:$B$12), MATCH(ROW($B$3:$B$12), ROW($B$3:$B$12)), ""),ROWS($A$1:A1)))

    I want to do this is one go (like hitting a button using VBA)

    Can anyone show me how can I do that?

    Thursday, November 7, 2019 3:43 PM

Answers

All replies

  • Hi Don Bradman,

    I've made a sample VBA.
        
    ' ---[Get Values] button
    Private Sub btn_GetValues_Click()
        ' --- get last name in column [B]
        Dim lastRow As Integer
        lastRow = Cells(Rows.Count, 2).End(xlUp).Row
        ' --- clear
        Range(Cells(3, 7), Cells(lastRow, 7)).Value = ""
        ' --- if nothing selected in [F3], do nothing
        If (Range("F3").Value = "") Then
            MsgBox "Select a Name" & vbCrLf & "from drop-down list in [F6]"
            Exit Sub
        End If
        ' --- find name
        Dim dispRow As Integer: dispRow = 3 ' -- row number for display Age
        Dim searchRow As Integer
        For searchRow = 3 To lastRow
            If (Cells(searchRow, 2).Value = Range("F3").Value) Then
                Cells(dispRow, 7).Value = Cells(searchRow, 3).Value
                dispRow = dispRow + 1
            End If
        Next
    End Sub
    
    I hope it will be helpful.

    Regards,

    Ashidacchi -- http://hokusosha.com

    Friday, November 8, 2019 1:47 AM
  • Hi Don Bradman,

    I suppose that cell [F3] should have a unique name as a validate list.
        

    So, I've made a macro.
    Please [Run] this macro "".
        
    ' --- make a UNIQUE validation list in cell[F3]
    Sub Create_Uniq_ValidateList()
        ' --- get last name in column [B]
        Dim lastRow As Integer
        lastRow = Cells(Rows.Count, 2).End(xlUp).Row
        ' --- create a string which does NOT have DUPLICATED value
        Dim NameList As String: NameList = ""
        Dim r As Integer
        For r = 3 To lastRow
            If (InStr(NameList, Cells(r, 2).Value) = 0) Then
                NameList = NameList & Cells(r, 2).Value & ","
            End If
        Next
        ' --- create Validation List in [F3] from NameList
        Range("F3").Validation.Delete
        With Range("F3").Validation
            .Add Type:=xlValidateList, Formula1:=NameList
        End With
    End Sub
    
    Regards,

    Ashidacchi -- http://hokusosha.com

    Friday, November 8, 2019 2:43 AM
  • Thanks Ashidacchi for your reply.

    BTW, I forgot to mention another format in which the items in the Name column in source column are merged as below:

    in that case it is not working properly and only taking the first match as in the second IF statement of your code when the values of cell(4,2), (6,2) gives blank its not working properly.

    Can you show me how can I get rid of that issue?

    Thanks in advance.

    Friday, November 8, 2019 8:56 AM
  • Hi Don Bradman,

    I've received a mail from this forum.
    In the mail, you said:

    Thanks Ashidacchi for your reply.

    BTW, I forgot to mention another format in which the items in the Name column in source column are merged as below:

    in that case it is not working properly and only taking the first match as in the second IF statement of your code when the values of cell(4,2), (6,2) gives blank its not working properly.

    Can you show me how can I get rid of that issue?

    Thanks in advance.

    But I can see your latest post in Web browser.
    Can you post it again?

    Regards,


    Ashidacchi -- http://hokusosha.com


    P.S.
    I guess something wrong occurred in this forum.
    I surely posted a post for other person, but it can not be seen. 
    • Edited by Ashidacchi Friday, November 8, 2019 9:18 AM
    Friday, November 8, 2019 9:15 AM
  • Hi Don Bradman,

    As often said, we should not merge cells or make a cell blank before all editing work is completed.
    In order to use my previous code with the least modification, we can do:
      1) insert two columns before column [A]
      2) copy current column [B] and [C] at a newly inserted [A] 
      3) modify code: old column number [2] should be number [4], i.e. add 2 to old column number 

    Sorry, it's time to eat and drink in Japan [UTC+9], so a newer code will be provided tomorrow.

    Regards,

    Ashidacchi -- http://hokusosha.com


    • Edited by Ashidacchi Friday, November 8, 2019 10:48 AM
    Friday, November 8, 2019 10:48 AM
  • Don, try this, assuming your data are in sheets(1):

    Sub macro1()
    Dim a As Integer, b As Integer, c As Integer, x As Integer, y As Integer
    With Sheets(1)
    a = .Cells(.Rows.Count, 2).End(xlUp).Row
    b = .Cells(.Rows.Count, 6).End(xlUp).Row
    c = .Cells(.Rows.Count, 7).End(xlUp).Row
    If b = 2 Then Exit Sub
    .Range(.Cells(3, 7), .Cells(c + 1, 7)).ClearContents
    y = 3
    For x = 3 To a
    If LCase(.Cells(x, 2)) = LCase(.Cells(y, 6)) Then
    .Cells(y, 7) = .Cells(x, 3)
    x = x + 1: y = y + 1
    Do While .Cells(x, 2) = 0 And x <= a
    .Cells(y, 7) = .Cells(x, 3)
    x = x + 1: y = y + 1
    Loop
    Exit Sub
    End If
    Next x
    End With
    End Sub


    • Edited by alphaaa Friday, November 8, 2019 1:40 PM
    Friday, November 8, 2019 1:25 PM
  • Thanks alphaaa it works.

    However, can you explain your code though? I'm a new to VBA.

    Friday, November 8, 2019 1:57 PM
  • Hi Don Bradman, Good moring from Japan

    I've modified my code according to your new requirement.
    ' ---[Get Values] button
    Private Sub btn_GetValues_Click()
        ' --- if nothing selected in [F3], do nothing
        If (Range("F3").Value = "") Then
            MsgBox "Select a Name" & vbCrLf & "from drop-down list in [F6]"
            Exit Sub
        End If
        ' ---
        Application.ScreenUpdating = False
        ' ===[note] column number is +2, after inserting 2 columns
        Call Insert_2_Columns    ' <<=== add on Version 2
        ' --- get last row in column [B]
        Dim lastrow As Integer
        lastrow = Cells(Rows.Count, 2).End(xlUp).Row
        ' --- clear (after adding 2 columns)
        Range(Cells(3, 7 + 2), Cells(lastrow, 7 + 2)).Value = ""
        ' --- find name
        Dim dispRow As Integer: dispRow = 3 ' -- row number for display Age
        Dim searchRow As Integer
        For searchRow = 3 To lastrow
            If (Cells(searchRow, 1).Value = Range("H3").Value) Then
                Cells(dispRow, 7 + 2).Value = Cells(searchRow, 2).Value
                dispRow = dispRow + 1
            End If
        Next
        ' === (added feature) Sort: using Option/Radio Buttons ===
        ' --- clear sort fields, get lastRow of Age(column [G])
        ActiveSheet.Sort.SortFields.Clear
        lastrow = Cells(Rows.Count, 7 + 2).End(xlUp).Row
        ' --- Ascending order
        If (rbt_Ascending.Value = True) Then
            ActiveSheet.Sort.SortFields.Add2 _
                Order:=xlAscending, _
                Key:=Range("I3:I" & lastrow)
            With ActiveSheet.Sort
                .SetRange Range("I3:I" & lastrow)
                .Header = xlNo
                .Orientation = xlTopToBottom
                .Apply
            End With
        End If
        ' --- Descending order
        If (rbt_Descending.Value = True) Then
            ActiveSheet.Sort.SortFields.Add2 _
                Order:=xlDescending, _
                Key:=Range("I3:I" & lastrow)
            With ActiveSheet.Sort
                .SetRange Range("I3:I" & lastrow)
                .Header = xlNo
                .Orientation = xlTopToBottom
                .Apply
            End With
        End If
        ' ---
        Call Delete_2_Columns    ' <<=== add on Version 2
        Range("F3").Select
        Application.ScreenUpdating = True
    End Sub
    
    ' --- Insert 2 work columns, and copy original Name & Age
    Private Sub Insert_2_Columns()
        ' --- Insert 2 columns
        Columns("A:B").Select
        Selection.Insert Shift:=xlToRight
        ' --- Copy Name[D],Age[E] to [A]
        Columns("D:E").Copy Columns("A")
        ' --- UnMerge all merged cells in column [A]
        Columns("A:A").MergeCells = False
        ' --- Fill the above name in column [A]
        Dim lastrow As Integer  ' -- use column [B], because [A] has blank
        lastrow = Cells(Rows.Count, 2).End(xlUp).Row
        Dim r As Integer
        For r = 4 To lastrow    ' -- From 4 to last Row
            If (Cells(r, 1).Value = "") Then
                Cells(r, 1).Value = Cells(r - 1, 1).Value
            End If
        Next
    End Sub
    ' --- Delete 2 work columns
    Private Sub Delete_2_Columns()
        Columns("A:B").Delete
    End Sub
    
    I've shared "DonBradman_Validationlist_v2.xlsm" via OneDrive.
    Please download it and check if it works.

    Cf.  As you can see on the below screenshot, I've add new features:
      1) [Set [F3]]  button -- it will create a new unique Validate List in [F3]  2) three Radio/Option buttons -- it will sort Age 

    Regards, 

    Ashidacchi -- http://hokusosha.com

    Saturday, November 9, 2019 12:12 AM
  • Hi, Ashidacchi

    Appreciate your added features.

    However ,talking about added features, if the result were like

    instead of

    it would have been more useful.

    Thanks :)



    • Edited by Don Bradman Saturday, November 9, 2019 1:18 AM
    Saturday, November 9, 2019 1:17 AM
  • Hi,

    I've shared "DonBradman_Validationlist_v3.xlsm" via OneDrive.
    I hope this will be the final version about your requirements.

    Regards,

    Ashidacchi -- http://hokusosha.com

    • Marked as answer by Don Bradman Saturday, November 9, 2019 1:46 AM
    Saturday, November 9, 2019 1:31 AM
  • Thanks. That will be all.:)
    Saturday, November 9, 2019 1:45 AM
  • Thanks alphaaa it works.

    However, can you explain your code though? I'm a new to VBA.

    Hi, Don

    a, b, and c calculate the last row with data in the columns B, F, and G.
    Further, I only use a few commands/instructions, namely:

    For - Next

    Do - While

    The meaning of those and other vba-words , you can find in the vba-helpfile of Excel (F1)

    Whát exactly do you not understand in my code?



    • Edited by alphaaa Saturday, November 9, 2019 10:11 AM
    Saturday, November 9, 2019 10:08 AM
  • @alphaaa,

    I tried your code.
    I'm afraid it does not work if Name rows are added, or merged cells are changed (merged cells are unmerged, or other cells merged).

    I'm sure that [For-Next], [Do While-Loop] is strong statement in code. It would be much better, if you added some comments in your code. That could make code be more understandable, easier to be read.

    Thanks,

    Ashidacchi -- http://hokusosha.com


    • Edited by Ashidacchi Saturday, November 9, 2019 11:18 AM
    Saturday, November 9, 2019 11:01 AM
  • Hi alphaaa,

    Like Ashidacchi mentioned, lack of comments in your code made it a little difficult for me as a newbie in vba.

    Also, in your code like

    b = .Cells(.Rows.Count, 6).End(xlUp).Row

    .Range(.Cells(3, 7), .Cells(c + 1, 7)).ClearContents

    .Cells(y, 7) = .Cells(x, 3)

     you started with just ".Cells", ".Range" etc without it having anything before it like say "abc.Cells" or "worksheet.Range". In all the basic tutorials I've not seen anything like that so that's why I was a little taken aback the first time I saw your code. That's why I posted that reply

    "can you explain your code though? I'm a new to VBA."

    Saturday, November 9, 2019 1:05 PM
  • Hi alphaaa,

    Like Ashidacchi mentioned, lack of comments in your code made it a little difficult for me as a newbie in vba.

    Also, in your code like

    b = .Cells(.Rows.Count, 6).End(xlUp).Row
    .Range(.Cells(3, 7), .Cells(c + 1, 7)).ClearContents
    .Cells(y, 7) = .Cells(x, 3)

    you started with just ".Cells", ".Range" etc without it having anything before it like say "abc.Cells" or "worksheet.Range". In all the basic tutorials I've not seen anything like that so that's why I was a little taken aback the first time I saw your code. That's why I posted that reply

    "can you explain your code though? I'm a new to VBA."

    @Don,
    In the macro you see:

    With sheets(1)
    ....
    ....
    End With

    Evertyhing you see between With Sheets(1) and End With beginning with a point (.) means that before that point you must read: Sheets(1) , so:
    a = .Cells(.Rows.Count, 2).End(xlUp).Row 
    you must read as:
    a = Sheets(1).Cells(Sheets(1).Rows.Count, 2).End(xlUp).Row 
    The same for b= , c= , and all the other words beginning with a point !
    See the vba-helpfile (F1) and search there for With
    For me, the helpfile has always been very usefull, and it wil also be for you, I think.
    Therefore: all the words of the macro you don't understand: look in the helpfile! 

    Explanation:

    Sub macro1()
    ' Declare all variables used in the macro
    Dim a As Integer, b As Integer, c As Integer, x As Integer, y As Integer

    a = .Cells(.Rows.Count, 2).End(xlUp).Row
    b = .Cells(.Rows.Count, 6).End(xlUp).Row
    c = .Cells(.Rows.Count, 7).End(xlUp).Row

    ' If the last cell in column F is 2 (with the word 'Name' = F2) there is nothing to do (ending the macro).
    If b = 2 Then Exit Sub

    ' Remove all the data in column G beginning in G3 (needed for every new name you type in F3).

    .Range(.Cells(3, 7), .Cells(c + 1, 7)).ClearContents

    ' In columns F and G we start in row  3 (y=3)
    y = 3

    Also in column B we start in row 3 (x=3), because in B3 we see the first name.
    We run through column b until the last rownumber (= a)
    For x = 3 To a

    ' By using 'Lcase' (or 'Ucase') then ik makes no difference if you use capitals (or not)  in the name.
    ' if the name in column B is equal to the name in F3, then
    If LCase(.Cells(x, 2)) = LCase(.Cells(y, 6)) Then

    copy the age from column C to Column G
    .Cells(y, 7) = .Cells(x, 3)

    ' If there are other ages, they must be come in the next row in column G, therefore: y=y+1
    ' In colum B: if the next cell (x=x+1) = 0 ( or empty), it means that there belong more ages
    ' at the same name. Therefore: as long as (Do while…Loop) the next cell in column B is 0 
    ' (or empty), the corresponding age in column C must be copied to column G.

    ' Notice that in your last example the cells B5, B6, and B7 are merged cells;
    ' this means: B5=Georges and B6 and B7 are emty (or 0).

    x = x + 1: y = y + 1
    Do While .Cells(x, 2) = 0 And x <= a
    .Cells(y, 7) = .Cells(x, 3)
    x = x + 1: y = y + 1
    Loop
    Exit Sub
    End If
    Next x
    End With
    End Sub

    I hope this helps.

    @ Ashidacchi,
    My code works (as Don Bradman confirmed), also if in column B names are added or removed, and also if merged cells are changed (merged cells are unmerged, or other cells merged) !




    • Edited by alphaaa Saturday, November 9, 2019 3:44 PM
    Saturday, November 9, 2019 3:34 PM
  • @ Ashidacchi,

    My code works (as Don Bradman confirmed), also if in column B names are added or removed, and also if merged cells are changed (merged cells are unmerged, or other cells merged) !




    @ alphaaa,

    I'm afraid your code is not sufficient, i.e. it does not work in some cases.
    We had better to take various cases into account.
    Please check your code with this case.
        

    Regards,

    Ashidacchi -- http://hokusosha.com

    Sunday, November 10, 2019 12:34 AM
  • @ alphaaa,I'm afraid your code is not sufficient, i.e. it does not work in some cases.We had better to take various cases into account.Please check your code with this case.

    @Ashidacc,
    It's logical to use in column B either merged cells or not merged cells, not both together.
    Also it's logical in column B to place same names in contiguous cells.
    That's why I did not include that in the code in my macro above.
    But, if you (or Don) insist on recording that, that's possible; see the macro below in which it's not necessary to insert or delete columns.
    It's possible that if the names in column B are inserted in another (strange) way, the code must be adjusted. But the macro below I think, can be applied for the most purposes.

    @Don,
    In the macro below you see two functions which I didn't use before: COUNTIF and MATCH. 
    In the vba-helpfile you can read what they do.
    In sheets(1): B2 = Name, C2 = Age, F2 = Name, G2 = Age, F3 = cell to type the name you will find.

    Sub macro2()
    Dim a As Integer, b As Integer, c As Integer, x As Integer, y As Integer Dim m As Integer, myrange As Range With Sheets(3) a = .Cells(.Rows.Count, 3).End(xlUp).Row b = .Cells(.Rows.Count, 6).End(xlUp).Row c = .Cells(.Rows.Count, 7).End(xlUp).Row If b = 2 Then Exit Sub .Range(.Cells(4, 6), .Cells(b + 1, 6)).ClearContents .Range(.Cells(3, 7), .Cells(c + 1, 7)).ClearContents x = 3: y = 3 begin: Do While x <= a If Application.And(IsEmpty(.Cells(x, 2)), IsEmpty(.Cells(x, 3))) Then GoTo nextone End If If LCase(.Cells(x, 2)) = LCase(.Cells(3, 6)) Then .Cells(y, 7) = .Cells(x, 3) .Cells(y, 6) = .Cells(3, 6) x = x + 1: y = y + 1 Do While Application.Or((LCase(.Cells(x, 2)) = LCase(.Cells(x - 1, 2))), _ Application.And(IsEmpty(.Cells(x, 2)), IsEmpty(.Cells(x, 3)) = False)) And x <= a .Cells(y, 7) = .Cells(x, 3): .Cells(y, 6) = .Cells(3, 6) x = x + 1: y = y + 1 Loop Set myrange = .Range(.Cells(x + 1, 2), .Cells(a, 2)) If Application.CountIf(myrange, LCase(.Cells(3, 6))) > 0 Then m = Application.Match(.Cells(3, 6), myrange, 0) x = x + m GoTo begin End If Exit Sub End If nextone: x = x + 1 Loop End With End Sub


    • Edited by alphaaa Sunday, November 10, 2019 12:12 PM
    Sunday, November 10, 2019 12:11 PM
  • @alphaaa,
       I guess you would be very mathematical or logical.
       But I did not try the code, because is is not easy to read/understand for me.

    @Don Bradman,
      I modified my code.
      It looks lengthy in contrast to alphaaa's code.
      But I prefer readability to smartness in code. And am used to use somewhat long variables for readability that will make code be modified easier in the future. 
     

    ' --- make a UNIQUE validation list in cell[F3] Private Sub btn_Set_F3_Click() ' --- Get last row in [C]: age not merged Dim lastRow As Integer lastRow = Cells(Rows.Count, 3).End(xlUp).Row ' --- Create a string which does NOT have DUPLICATED value Dim NameList As String: NameList = "" Dim r As Integer For r = 3 To lastRow If (InStr(NameList, Cells(r, "B").Value) = 0) Then NameList = NameList & Cells(r, "B").Value & "," End If Next ' --- Create Validation List in [F3] from NameList Range("F3").Validation.Delete With Range("F3").Validation .Add Type:=xlValidateList, Formula1:=NameList End With ' --- Clear result area Range("F4:F" & lastRow).Value = "" Range("G3:G" & lastRow).Value = "" Range("G3:G" & lastRow).Interior.ColorIndex = xlNone End Sub ' === [Get Values] button ================================== Private Sub btn_GetValues_Click() ' --- if nothing selected in [F3], do nothing If (Range("F3").Value = "") Then MsgBox "Select a Name" & vbCrLf & "from drop-down list in [F3]" Exit Sub End If ' --- Application.ScreenUpdating = False ' ===[note] column number is +2, after inserting 2 columns Call Insert_2_Columns ' <<=== add on Version 2 ' --- get last row in column [B] Dim lastRow As Integer lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' --- clear (after adding 2 columns) Range(Cells(4, 6 + 2), Cells(lastRow, 6 + 2)).Value = "" ' -- Name Range(Cells(3, 7 + 2), Cells(lastRow, 7 + 2)).Value = "" ' -- Age Range(Cells(3, 7 + 2), Cells(lastRow, 7 + 2)).Interior.Color = xlNone ' --- find name Dim dispRow As Integer: dispRow = 3 ' -- row number for display Age Dim searchRow As Integer For searchRow = 3 To lastRow If (Cells(searchRow, 1).Value = Range("H3").Value) Then Cells(dispRow, 6 + 2).Value = Range("H3").Value Cells(dispRow, 7 + 2).Value = Cells(searchRow, 2).Value Cells(dispRow, 7 + 2).Interior.ColorIndex = 34 dispRow = dispRow + 1 End If Next ' === (added feature) Sort: using Option/Radio Buttons === Call prc_Sort(lastRow) ' --- Call Delete_2_Columns ' <<=== add on Version 2 Range("F3").Select Application.ScreenUpdating = True End Sub ' === (added feature) Sort: using Option/Radio Buttons === Private Sub prc_Sort(ByVal lastRow As Integer) ' --- clear sort fields, get lastRow of Age(column [G]) ActiveSheet.Sort.SortFields.Clear lastRow = Cells(Rows.Count, 7 + 2).End(xlUp).Row ' --- Ascending order If (rbt_Ascending.Value = True) Then ActiveSheet.Sort.SortFields.Add2 _ Order:=xlAscending, _ Key:=Range("I3:I" & lastRow) With ActiveSheet.Sort .SetRange Range("I3:I" & lastRow) .Header = xlNo .Orientation = xlTopToBottom .Apply End With End If ' --- Descending order If (rbt_Descending.Value = True) Then ActiveSheet.Sort.SortFields.Add2 _ Order:=xlDescending, _ Key:=Range("I3:I" & lastRow) With ActiveSheet.Sort .SetRange Range("I3:I" & lastRow) .Header = xlNo .Orientation = xlTopToBottom .Apply End With End If End Sub ' --- Insert 2 work columns, and copy original Name & Age Private Sub Insert_2_Columns() ' --- Insert 2 columns Columns("A:B").Select Selection.Insert Shift:=xlToRight ' --- Copy Name[D],Age[E] to [A] Columns("D:E").Copy Columns("A") ' --- UnMerge all merged cells in column [A] Columns("A:A").MergeCells = False ' --- Fill the above name in column [A] Dim lastRow As Integer ' -- use column [B], because [A] has blank lastRow = Cells(Rows.Count, 2).End(xlUp).Row Dim r As Integer For r = 4 To lastRow ' -- From 4 to last Row If (Cells(r, 1).Value = "") Then Cells(r, 1).Value = Cells(r - 1, 1).Value End If Next End Sub

    ' --- Delete 2 work columns Private Sub Delete_2_Columns() Columns("A:B").Delete End Sub

    Regards,

    Ashidacchi -- http://hokusosha.com

    Monday, November 11, 2019 10:20 PM
  • @Don,
    In the macro before this one, in line 4 y ou see: With Sheets(3), but if your data are in Sheets(1), of course  it must be: With Sheets(1). I have changed that in the macro below and I made another adaptation so that it isn't necessary to use the function MATCH.
    Unfortenately, for some reason on this forum I cannot insert an image in my message. Try this link (without quotes) to see the Excel-table: "https://imgur.com/pOoFH2c"

    With the code (macro1(), below this text), the names are in column B of Sheets(1), starting in B3, the name to find is in F3 os Sheets(1) .

    In the macro only this vba-functions are used:
    And, Or, Goto, If - Then, LCase, IsEmpty, With - End With, Do While - Loop, Countif . They all belong (or must belong) to the knowledge of a programmer-beginner.

    Further, it's a small macro and most of the lines look if a cell-value = equal to another one (or less or more than another one), almost averyone can understand that I think. But: computer-programming (in any language) you learn it by  doing it yourself (years and years), not by copying code from others.

    Sub macro1() Dim a As Integer, b As Integer, c As Integer, x As Integer, y As Integer Dim myname As String, myrange As Range With Sheets(1) a = .Cells(.Rows.Count, 3).End(xlUp).Row b = .Cells(.Rows.Count, 6).End(xlUp).Row c = .Cells(.Rows.Count, 7).End(xlUp).Row If b = 2 Then Exit Sub myname = LCase(.Cells(3, 6).Value) .Range(.Cells(4, 6), .Cells(b + 1, 6)).ClearContents .Range(.Cells(3, 7), .Cells(c + 1, 7)).ClearContents x = 3: y = 3 begin: Do While x <= a If Application.And(IsEmpty(.Cells(x, 2)), IsEmpty(.Cells(x, 3))) Then GoTo nextone End If If LCase(.Cells(x, 2)) = myname Then .Cells(y, 7) = .Cells(x, 3): .Cells(y, 6) = .Cells(3, 6) x = x + 1: y = y + 1 Do While Application.Or((LCase(.Cells(x, 2)) = myname), _ Application.And(IsEmpty(.Cells(x, 2)), IsEmpty(.Cells(x, 3)) = False)) And x <= a .Cells(y, 7) = .Cells(x, 3): .Cells(y, 6) = .Cells(3, 6) x = x + 1: y = y + 1 Loop Set myrange = .Range(.Cells(x + 1, 2), .Cells(a, 2)) If Application.CountIf(myrange, LCase(.Cells(3, 6))) > 0 Then GoTo begin End If Exit Sub End If nextone: x = x + 1 Loop End With End Sub

    @Ashidacchi,
    To be a computer-programmer, you must think logical, that's sure.
    For programming, to be a mathematical specialist can be very usefull, but is not absolutely necessary (for some problems however, it is (but not for the problem in this topic)).


    • Edited by alphaaa Tuesday, November 12, 2019 1:19 PM
    Tuesday, November 12, 2019 10:32 AM