Need help with excel formula

I am attaching  the spreadsheet .I need help to achieve that .Please let me know if you have any questions.
I want to merge rows into one .Please take a look at the attached spreadsheet.
TEST_WORK_BOOK.xlsx
Chaitu235Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Patrick MatthewsCommented:
For any given Source value, how many rows might there be?
Always 2 (as in the sample file)?
Either 1 or 2?
Sometimes more than 2?
If sometimes more than 2, what is the upper limit?

Depending on the answer to this, a formula approach may not be workable, and VBA may be required.
Chaitu235Author Commented:
Sometime more than 2 we dont have the upper limit .5 can be a good number for upper limit
Patrick MatthewsCommented:
we dont have the upper limit .5 can be a good number for upper limit

Either you have an upper limit, or you don't.
JavaScript Best Practices

Save hours in development time and avoid common mistakes by learning the best practices to use for JavaScript.

Chaitu235Author Commented:
What i meant was we dont have a specific number .So we can say 5 is a good number for coding..
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Try this....
Sub ReArrangeData()
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, dlr As Long
Dim sRng As Range, Cell As Range, oCell As Range
Dim Officer As String
Dim Source
Set sws = Sheets("sheet1")
Set dws = Sheets("Sheet2")

Application.ScreenUpdating = False
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
Set sRng = sws.Range("A2:A" & slr)
dws.Cells.Clear
dws.Range("A1:B1").Value = Array("Source", "Offcier")
sws.AutoFilterMode = 0
For Each Cell In sRng
   If Cell <> Source Then
      Source = Cell
      With sws.Rows(1)
         .AutoFilter field:=1, Criteria1:=Cell
         If sws.Range("B1:B" & slr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
            For Each oCell In sws.Range("B2:B" & slr).SpecialCells(xlCellTypeVisible)
               If Officer = "" Then
                  Officer = oCell
               Else
                  Officer = Officer & "/" & oCell
               End If
            Next oCell
         End If
      End With
      dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row + 1
      dws.Cells(dlr, "A") = Cell
      dws.Cells(dlr, "B") = Officer
      Officer = ""
   End If
Next Cell
sws.AutoFilterMode = 0
dws.Activate
Application.ScreenUpdating = True
MsgBox "Finished.", vbInformation
End Sub

Open in new window

Refer to the attached workbook and click the button on Sheet1 to get the desired output on Sheet2.
TEST_WORK_BOOK.xlsm
Patrick MatthewsCommented:
For problems like this I prefer to use a "Dictionary of Dictionaries" approach as outlined in my article here:

http://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html

The code here returns every unique officer value for each source value.  It works on any number of rows for any given source value.  If you prefer to get the duplicates too, if they exist, the code change is quite small.

Sub GroupTheValues()
    
    Dim ParentDic As Object
    Dim ChildDic As Object
    Dim LastR As Long
    Dim SourceArr As Variant
    Dim Counter As Long
    Dim SourceValue As Variant
    Dim OfficerValue As Variant
    Dim DestWs As Worksheet
    Dim DestRow As Long
    
    Const SourceWsName As String = "Source"
    
    Set ParentDic = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook.Worksheets(SourceWsName)
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        SourceArr = .Range("a1:b" & LastR).Value
    End With
    
    For Counter = 2 To LastR 'skip first row because it's just headers
        SourceValue = SourceArr(Counter, 1)
        OfficerValue = SourceArr(Counter, 2)
        If ParentDic.Exists(SourceValue) Then
            Set ChildDic = ParentDic.Item(SourceValue)
        Else
            Set ChildDic = CreateObject("Scripting.Dictionary")
            ParentDic.Add SourceValue, ChildDic
        End If
        If Not ChildDic.Exists(OfficerValue) Then
            ChildDic.Add OfficerValue, OfficerValue
        End If
    Next
    
    SourceArr = ParentDic.Keys
    
    Set DestWs = ThisWorkbook.Worksheets.Add
    With DestWs
        .Columns(1).NumberFormat = "@"
        .Cells(1, 1) = "Source"
        .Cells(1, 2) = "Officer"
        DestRow = 2
        For Counter = LBound(SourceArr) To UBound(SourceArr)
            Set ChildDic = ParentDic.Item(SourceArr(Counter))
            .Cells(DestRow, 1) = SourceArr(Counter)
            .Cells(DestRow, 2) = Join(ChildDic.Keys, "/")
            DestRow = DestRow + 1
        Next
    End With
    
    Set ChildDic = Nothing
    Set ParentDic = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

Patrick MatthewsCommented:
Sorry, meant to include a sample file :)

For problems like this I prefer to use a "Dictionary of Dictionaries" approach as outlined in my article here:

http://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html

The code here returns every unique officer value for each source value.  It works on any number of rows for any given source value.  If you prefer to get the duplicates too, if they exist, the code change is quite small.

Sub GroupTheValues()
    
    Dim ParentDic As Object
    Dim ChildDic As Object
    Dim LastR As Long
    Dim SourceArr As Variant
    Dim Counter As Long
    Dim SourceValue As Variant
    Dim OfficerValue As Variant
    Dim DestWs As Worksheet
    Dim DestRow As Long
    
    Const SourceWsName As String = "Source"
    
    Set ParentDic = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook.Worksheets(SourceWsName)
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        SourceArr = .Range("a1:b" & LastR).Value
    End With
    
    For Counter = 2 To LastR 'skip first row because it's just headers
        SourceValue = SourceArr(Counter, 1)
        OfficerValue = SourceArr(Counter, 2)
        If ParentDic.Exists(SourceValue) Then
            Set ChildDic = ParentDic.Item(SourceValue)
        Else
            Set ChildDic = CreateObject("Scripting.Dictionary")
            ParentDic.Add SourceValue, ChildDic
        End If
        If Not ChildDic.Exists(OfficerValue) Then
            ChildDic.Add OfficerValue, OfficerValue
        End If
    Next
    
    SourceArr = ParentDic.Keys
    
    Set DestWs = ThisWorkbook.Worksheets.Add
    With DestWs
        .Columns(1).NumberFormat = "@"
        .Cells(1, 1) = "Source"
        .Cells(1, 2) = "Officer"
        DestRow = 2
        For Counter = LBound(SourceArr) To UBound(SourceArr)
            Set ChildDic = ParentDic.Item(SourceArr(Counter))
            .Cells(DestRow, 1) = SourceArr(Counter)
            .Cells(DestRow, 2) = Join(ChildDic.Keys, "/")
            DestRow = DestRow + 1
        Next
    End With
    
    Set ChildDic = Nothing
    Set ParentDic = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

q_28785800.xlsm
Chaitu235Author Commented:
Attaching updated spreadsheet as per the requirement change .Sorry for the change.please help me achieve this

Thanks,
Chaitu235
TEST_WORK_BOOK.xlsx
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
While asking question and providing the sample workbook, you must make sure that you have reviewed your requirement and sample workbook before posting your question and uploading the sample workbook to make sure that your are asking for help correctly as per your actual requirement.

We all are volunteers here and devote some free time to help others to resolve their issues and we don't get paid for our work here. And remember writing codes take time and we manage somehow to do that for you though we are not bound to do that.

So you are requested to take care of this in your future questions.

Please find the attached workbook and see if you get the desired output as per your requirement now.
TEST_WORK_BOOK-v2.xlsm

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Patrick MatthewsCommented:
Chaitu235,

With respect, you've gotten two solid answers to the original question you asked.

It is also not at all clear what you are expecting with these new requirements.  Based on the sample input, what is the exact output you are expecting?

My recommendation is that you close this question, as it has been answered, and if needed open a new question to address your new requirements.

Patrick
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.