Welcome :Guest

Congratulations!!!

Top 5 Contributors of the Month
yasminpriya
Gaurav Pal
Ram
christianasteves

 Home >> Forum >> Others >> Post New Question Subscribe to Forum
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
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
.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
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
.Name = "Outcome"
.Cells(1).Resize(k, nc) = c
End With
End Sub