Merge Cells?

M

msnyc07

I need to remove duplicate cells but besides specifying which cells
constitute a match I want to specify what to do with conflicting values in
the duplicates.

For instance one thing I'd like to do for some cells is combine/concatanate

So if I was merging on Field 1 but wanted to concatanate field 2:

Cat | Brown
Cat | White
Dog | Spotted
Dog | Striped

I'd end up with

Cat | Brown; White
Dog | Spotted; Striped

Likewise if I just wanted one value I'd like to use another field (e.g.
SourceField) to do so. So in the same instance if I wanted to merge/remove
dupes on Field 1 and use the values from Field 2 where value in Field3
(Source) = "Library"

Cat | Brown | Library
Cat | White | Wikipedia
Dog | Striped | Opinion
Dog | Spotted | Library

I'd end up with

Cat | Brown
Dog | Spotted

Are these possible with formulas?
 
J

JLatham

Well, I personally wouldn't attempt it with worksheet functions, although
others might. So if you can accept a VBA solution, you're welcome to use
this one.

2 routines are provided, one for the first case you laid out, one for the
second (with 'source' considered).

To get the code to work in your workbook, open (a copy of) your workbook and
press [Alt]+[F11] to enter the VB Editor. In there, choose Insert --> Module
and copy the code below and paste it into the module presented to you. Make
any edits you need to the 'Const' values for both routines. Close the VB
Editor.

Use Tools-->Macro-->Macros to choose which one to [Run]. Should work for
you as long as macros are enabled in the workbook.

Here's the code.

Sub Merge2Fields()
'change these constants as required
'sheet name with original list
Const srcWSName = "Sheet1"
'column with 'cat'/'dog'/etc in it
Const primeCol = "A"
'first row with a data entry in it
Const firstEntryRow = 2 ' assumes 1 row of labels
'column with 'brown'/'spotted' etc in it
Const secondaryCol = "B"
'new, clean sheet to put results on
Const destWSName = "Sheet2"

Dim srcWS As Worksheet
Dim srcRange As Range
Dim anySrcCell As Range
Dim destWS As Worksheet
Dim destRange As Range
Dim anyDestCell As Range
Dim offset2Sec As Integer
Dim inMemList() As String
Dim PLC As Long ' loop counter
Dim foundFlag As Boolean

Set srcWS = ThisWorkbook. _
Worksheets(srcWSName)
Set destWS = ThisWorkbook. _
Worksheets(destWSName)
'initialize some things
offset2Sec = _
Range(secondaryCol & 1).Column - _
Range(primeCol & 1).Column
ReDim inMemList(1 To 1)
ReDim inMemSecList(1 To 1)
'first stage, get list of unique
'primary items
Set srcRange = srcWS.Range(primeCol & _
firstEntryRow & ":" & _
srcWS.Range(primeCol & Rows.Count). _
End(xlUp).Address)
For Each anySrcCell In srcRange
foundFlag = False
For PLC = LBound(inMemList) To _
UBound(inMemList)
If Trim(anySrcCell) = _
inMemList(PLC) Then
foundFlag = True ' already in list
Exit For
End If
Next
If Not foundFlag Then
inMemList(UBound(inMemList)) = _
Trim(anySrcCell)
ReDim Preserve _
inMemList(1 To UBound(inMemList) + 1)
End If
Next
If UBound(inMemList) > 1 Then
ReDim Preserve _
inMemList(1 To UBound(inMemList) - 1)
Else
MsgBox "No 'prime' items found. Quitting", _
vbOKOnly, "No List to Work With"
Set srcRange = Nothing
Set srcWS = Nothing
Set destWS = Nothing
Exit Sub
End If
'put the results on the destination sheet
For PLC = LBound(inMemList) To _
UBound(inMemList)
destWS.Range(primeCol & Rows.Count). _
End(xlUp).Offset(1, 0) = inMemList(PLC)
Next
'stage 2: find unique identifiers for each
'entry in the 'new' list
Set destRange = destWS.Range(primeCol & _
firstEntryRow & ":" & _
destWS.Range(primeCol & Rows.Count). _
End(xlUp).Address)
'get each entry in the new(destination) list
'match it to the entries in the original list
'then pick up the identifier and make sure
'it is unique and if it is, add it to the
'identifier on the destination sheet
For Each anyDestCell In destRange
ReDim inMemList(1 To 1) ' clear each time
For Each anySrcCell In srcRange
If Trim(anySrcCell) = anyDestCell Then
foundFlag = False
For PLC = LBound(inMemList) To _
UBound(inMemList)
If Trim(anySrcCell.Offset(0, offset2Sec)) = _
inMemList(PLC) Then
foundFlag = True ' already in list
Exit For
End If
Next
If Not foundFlag Then
inMemList(UBound(inMemList)) = _
Trim(anySrcCell.Offset(0, offset2Sec))
If Not IsEmpty(anyDestCell.Offset(0, _
offset2Sec)) Then
anyDestCell.Offset(0, offset2Sec) = _
anyDestCell.Offset(0, offset2Sec) & _
"; " & anySrcCell.Offset(0, offset2Sec)
Else
anyDestCell.Offset(0, offset2Sec) = _
anySrcCell.Offset(0, offset2Sec)
End If
ReDim Preserve _
inMemList(1 To UBound(inMemList) + 1)
End If
End If
Next
Next
'housekeeping
Set srcRange = Nothing
Set srcWS = Nothing
Set destRange = Nothing
Set destWS = Nothing
End Sub

Sub Merge3Fields()
'This one will ask you for the 'Source' to filter by

'change these constants as required
'sheet name with original list
Const srcWSName = "Sheet1"
'column with 'cat'/'dog'/etc in it
Const primeCol = "A"
'first row with a data entry in it
Const firstEntryRow = 2 ' assumes 1 row of labels
'column with 'brown'/'spotted' etc in it
Const secondaryCol = "B"
'column with the 'source' information in it
Const sourceCol = "C"
'new, clean sheet to put results on
Const destWSName = "Sheet2"

Dim SourceEntry As String
Dim srcWS As Worksheet
Dim srcRange As Range
Dim anySrcCell As Range
Dim destWS As Worksheet
Dim destRange As Range
Dim anyDestCell As Range
Dim offset2Sec As Integer
Dim offset2Source As Integer
Dim inMemList() As String
Dim PLC As Long ' loop counter
Dim foundFlag As Boolean

Set srcWS = ThisWorkbook. _
Worksheets(srcWSName)
Set destWS = ThisWorkbook. _
Worksheets(destWSName)
'initialize some things
offset2Sec = _
Range(secondaryCol & 1).Column - _
Range(primeCol & 1).Column
offset2Source = _
Range(sourceCol & 1).Column - _
Range(primeCol & 1).Column

'get the source to filter by from the user
SourceEntry = InputBox("Enter the 'Source' to filter with:", _
"Source Entry", "")
'if no entry, quit
If Trim(SourceEntry) = "" Then
MsgBox "No Source Provided. Quitting.", vbOKOnly, _
"User Aborted Process"
Set srcWS = Nothing
Set destWS = Nothing
Exit Sub
End If
SourceEntry = UCase(Trim(SourceEntry))

ReDim inMemList(1 To 1)
ReDim inMemSecList(1 To 1)
'first stage, get list of unique
'primary items
Set srcRange = srcWS.Range(primeCol & _
firstEntryRow & ":" & _
srcWS.Range(primeCol & Rows.Count). _
End(xlUp).Address)
For Each anySrcCell In srcRange
If UCase(Trim(anySrcCell.Offset(0, offset2Source))) = _
SourceEntry Then
foundFlag = False
For PLC = LBound(inMemList) To _
UBound(inMemList)
If Trim(anySrcCell) = _
inMemList(PLC) Then
foundFlag = True ' already in list
Exit For
End If
Next
If Not foundFlag Then
inMemList(UBound(inMemList)) = _
Trim(anySrcCell)
ReDim Preserve _
inMemList(1 To UBound(inMemList) + 1)
End If
End If
Next
If UBound(inMemList) > 1 Then
ReDim Preserve _
inMemList(1 To UBound(inMemList) - 1)
Else
MsgBox "No 'prime' items found. Quitting", _
vbOKOnly, "No List to Work With"
Set srcRange = Nothing
Set srcWS = Nothing
Set destWS = Nothing
Exit Sub
End If
'put the results on the destination sheet
For PLC = LBound(inMemList) To _
UBound(inMemList)
destWS.Range(primeCol & Rows.Count). _
End(xlUp).Offset(1, 0) = inMemList(PLC)
Next
'stage 2: find unique identifiers for each
'entry in the 'new' list
Set destRange = destWS.Range(primeCol & _
firstEntryRow & ":" & _
destWS.Range(primeCol & Rows.Count). _
End(xlUp).Address)
'get each entry in the new(destination) list
'match it to the entries in the original list
'then pick up the identifier and make sure
'it is unique and if it is, add it to the
'identifier on the destination sheet
For Each anyDestCell In destRange
ReDim inMemList(1 To 1) ' clear each time
For Each anySrcCell In srcRange
If Trim(anySrcCell) = anyDestCell And _
UCase(Trim(anySrcCell.Offset(0, offset2Source))) _
= SourceEntry Then
foundFlag = False
For PLC = LBound(inMemList) To _
UBound(inMemList)
If Trim(anySrcCell.Offset(0, offset2Sec)) = _
inMemList(PLC) Then
foundFlag = True ' already in list
Exit For
End If
Next
If Not foundFlag Then
inMemList(UBound(inMemList)) = _
Trim(anySrcCell.Offset(0, offset2Sec))
If Not IsEmpty(anyDestCell.Offset(0, _
offset2Sec)) Then
anyDestCell.Offset(0, offset2Sec) = _
anyDestCell.Offset(0, offset2Sec) & _
"; " & anySrcCell.Offset(0, offset2Sec)
Else
anyDestCell.Offset(0, offset2Sec) = _
anySrcCell.Offset(0, offset2Sec)
End If
ReDim Preserve _
inMemList(1 To UBound(inMemList) + 1)
End If
End If
Next
Next
'housekeeping
Set srcRange = Nothing
Set srcWS = Nothing
Set destRange = Nothing
Set destWS = Nothing
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Can I use a formula to filter data? 8
merging text from two cells 2
Inserting Text 1
Remove Duplicate with 'Caveat' 2
why do I get an error message when i try to merge cells? 5
Does anyone know of any 'Smart' Duplicate Remover? 1
2007 Merge cells taking forever 7
MERGE ROW CELLS BY MACRO 2

Top