.NET Tutorials, Forums, Interview Questions And Answers
Welcome :Guest
 
Sign In
Register
 
Win Surprise Gifts!!!
Congratulations!!!


Top 5 Contributors of the Month
david stephan

Home >> Forum >> Others >> Post New QuestionBookmark and Share Subscribe to Forum

Excel Macro

Posted By: Aruna     Posted Date: November 01, 2010    Points:2   Category :Others
I need to find duplicates and merge the cells in the Excel sheet.

Input file:

100 aaa bbb Apple Banana
100 aaa bbb Orange custard
100 aaa bbb mango guava


output:

100 aaa bbb Apple Banana
Orange custard
mango guava


i have 1000 of records in a sheet.

please suggest a macro for this.



Responses
Author: Syed Shakeer Hussain             
Posted Date: November 01, 2010     Points: 5   
Author: Aruna             
Posted Date: November 01, 2010     Points: 5   

Thanks for your reply. I have achieved it through the following code.

Sub combduprows()
Dim nr As Long, nc As Integer, fcol As Integer
Dim b, c()
Dim i As Integer, x, k As Long, j As Integer
With Cells(1).CurrentRegion
nr = .Rows.Count
nc = .Columns.Count
fcol = .Resize(1).Find("ColumnName ").Column
b = .Value
End With
ReDim c(1 To nr, 1 To nc)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To nr
x = b(i, fcol)
If Not .exists(x) Then
k = k + 1
.Add x, i
For j = 1 To nc
c(k, j) = b(i, j)
Next j
Else
For j = 1 To nc
If Not j = fcol Then
If Not b(.Item(x), j) = b(i, j) Then
If Not IsEmpty(b(i, j)) Then
c(k, j) = c(k, j) & " & " & b(i, j)
Cells(i, nc + 2 + j) = b(i, j)
End If
End If
End If
Next j
End If
Next i
End With
With Sheets.Add
.Name = "Outcome"
.Cells(1).Resize(k, nc) = c
End With
End Sub

Author: Aruna             
Posted Date: November 01, 2010     Points: 5   

Thanks for your reply. I have achieved it through the following code.

Sub combduprows()
Dim nr As Long, nc As Integer, fcol As Integer
Dim b, c()
Dim i As Integer, x, k As Long, j As Integer
With Cells(1).CurrentRegion
nr = .Rows.Count
nc = .Columns.Count
fcol = .Resize(1).Find("ColumnName ").Column
b = .Value
End With
ReDim c(1 To nr, 1 To nc)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To nr
x = b(i, fcol)
If Not .exists(x) Then
k = k + 1
.Add x, i
For j = 1 To nc
c(k, j) = b(i, j)
Next j
Else
For j = 1 To nc
If Not j = fcol Then
If Not b(.Item(x), j) = b(i, j) Then
If Not IsEmpty(b(i, j)) Then
c(k, j) = c(k, j) & " & " & b(i, j)
Cells(i, nc + 2 + j) = b(i, j)
End If
End If
End If
Next j
End If
Next i
End With
With Sheets.Add
.Name = "Outcome"
.Cells(1).Resize(k, nc) = c
End With
End Sub



Post Reply

You must Sign In To post reply
 
 
Find more Forum Questions on C#, ASP.Net, Vb.Net, SQL Server and more Here
Quick Links For Forum Categories:
ASP.NetWindows Application  .NET Framework  C#  VB.Net  ADO.Net  
Sql Server  SharePoint  OOPs  SilverlightIISJQuery
JavaScript/VBScriptBiztalkWPFPatten/PracticesWCFOthers
www.DotNetSpark.comUnAnsweredAll

Hall of Fame    Twitter   Terms of Service    Privacy Policy    Contact Us    Archives   Tell A Friend