Excel: Merge adjacent rows if they contain the same values

Closed
kobe1121 Posts 11 Registration date Wednesday October 10, 2012 Status Member Last seen October 29, 2012 - Oct 10, 2012 at 04:24 AM
lukal4 Posts 1 Registration date Wednesday December 17, 2014 Status Member Last seen December 17, 2014 - Dec 17, 2014 at 05:06 PM
Hello all,

I am trying to speed up a task which I have do it manually with VBA:

There is a table like below"

Date;Name;ID;Text
20120101;Peter;00001;ABTC
20120102;May;00002;DdfEF
20120102;Jane;00002;GHIRTE
20120204;Larry;00003;qweR
20120506;Larry;00004;klnfdg
20120506;Tom;00004;ewrwrk
20120506;Ray;00004;sdfff
20120506;Ron;00005;kkkk


What I need to do is to merge adaject rows whenever they contain the same ID, resulting:

Date;Name;ID;Text
20120101;Peter;00001;ABTC
20120102;May;00002;DdfEF
20120102;Jane;*MERGED*;GHIRTE
20120204;Larry;00003;qweR
20120506;Larry;00004;klnfdg
20120506;Tom;*MERGED*;ewrwrk
20120506;Ray;*MERGED*;sdfff
20120506;Ron;00005;kkkk

Can anyone help me to figure out how should I write the macro? Thanks a lot.

5 responses

rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
Oct 10, 2012 at 06:05 AM
Try this

Option Explicit

Public Sub mergeInformation()
    Dim targetSheet         As String
    Dim totalRows           As Long
    Dim currentRow          As Long
    Dim startRow            As Long
    Dim lastProcessedId     As String
    Dim targetColumn        As String
    
    targetSheet = "Sheet1"
    targetColumn = "C"
    startRow = 2
    
    With Sheets(targetSheet)
        totalRows = getItemLocation("*", .Cells)
        lastProcessedId = "Nothing Processed"
        
        For currentRow = startRow To totalRows
            If (.Cells(currentRow, targetColumn) <> lastProcessedId) Then
               lastProcessedId = .Cells(currentRow, targetColumn)
            Else
                .Cells(currentRow, targetColumn) = """MERGED"""
            End If
        Next currentRow
    End With
End Sub

Public Function getItemLocation(sLookFor As String, _
                                rngSearch As Range, _
                                Optional bFullString As Boolean = True, _
                                Optional bLastOccurance As Boolean = True, _
                                Optional bFindRow As Boolean = True) As Long
                                   
   'find the first/last row/column  within a range for a specific string
      
   Dim Cell             As Range
   Dim iLookAt          As Integer
   Dim iSearchDir       As Integer
   Dim iSearchOdr       As Integer
         
   If (bFullString) _
   Then
      iLookAt = xlWhole
   Else
      iLookAt = xlPart
   End If
   If (bLastOccurance) _
   Then
      iSearchDir = xlPrevious
   Else
      iSearchDir = xlNext
   End If
   If Not (bFindRow) _
   Then
      iSearchOdr = xlByColumns
   Else
      iSearchOdr = xlByRows
   End If
         
   With rngSearch
      If (bLastOccurance) _
      Then
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
      Else
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
      End If
   End With
         
   If Cell Is Nothing Then
      getItemLocation = 0
   ElseIf Not (bFindRow) _
   Then
      getItemLocation = Cell.Column
   Else
      getItemLocation = Cell.Row
   End If
   Set Cell = Nothing

End Function
0
kobe1121 Posts 11 Registration date Wednesday October 10, 2012 Status Member Last seen October 29, 2012
Oct 10, 2012 at 08:09 PM
Sorry, there is a misunderstanding. I want the cells with the same ID to be actually merged instead of showing the text "merged". Is there a way to do so? Thanks a lot.
0
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
Oct 10, 2012 at 08:26 PM
like how ? you need to give example. the code follow your sample example. it is case of GIGO
0
kobe1121 Posts 11 Registration date Wednesday October 10, 2012 Status Member Last seen October 29, 2012
Oct 10, 2012 at 08:59 PM
You can download the sample file here (please remove the space):

w w w.2shared.c o m/document/ik2GvQZK/Demo.html

I have added a complication which looks more like the actual worksheet I am working on.

Thanks for your help.
0
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
Oct 11, 2012 at 06:04 AM
then try this
Option Explicit

Public Sub mergeInformation()
    Dim targetSheet         As String
    Dim totalRows           As Long
    Dim currentRow          As Long
    Dim currentColumn       As Integer
    Dim startRow            As Long
    Dim lastProcessedId     As Variant
    Dim targetColumn        As Variant
    
    targetSheet = "Sheet1"
    targetColumn = Array("A", "B", "C")
    startRow = 2
    
    With Sheets(targetSheet)
        totalRows = getItemLocation("*", .Cells)
        lastProcessedId = Array("Nothing Processed", "Nothing Processed", "Nothing Processed")
        
        For currentRow = startRow To totalRows
            For currentColumn = LBound(targetColumn) To UBound(targetColumn)
                If (.Cells(currentRow, targetColumn(currentColumn)) <> lastProcessedId(currentColumn)) Then
                   lastProcessedId(currentColumn) = .Cells(currentRow, targetColumn(currentColumn))
                Else
                    .Cells(currentRow, targetColumn(currentColumn)) = vbNullString
                    .Range(.Cells(currentRow - 1, targetColumn(currentColumn)), .Cells(currentRow, targetColumn(currentColumn))).MergeCells = True
                    
                End If
            Next
        Next currentRow
    End With
End Sub

Public Function getItemLocation(sLookFor As String, _
                                rngSearch As Range, _
                                Optional bFullString As Boolean = True, _
                                Optional bLastOccurance As Boolean = True, _
                                Optional bFindRow As Boolean = True) As Long
                                   
   'find the first/last row/column  within a range for a specific string
      
   Dim Cell             As Range
   Dim iLookAt          As Integer
   Dim iSearchDir       As Integer
   Dim iSearchOdr       As Integer
         
   If (bFullString) _
   Then
      iLookAt = xlWhole
   Else
      iLookAt = xlPart
   End If
   If (bLastOccurance) _
   Then
      iSearchDir = xlPrevious
   Else
      iSearchDir = xlNext
   End If
   If Not (bFindRow) _
   Then
      iSearchOdr = xlByColumns
   Else
      iSearchOdr = xlByRows
   End If
         
   With rngSearch
      If (bLastOccurance) _
      Then
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
      Else
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
      End If
   End With
         
   If Cell Is Nothing Then
      getItemLocation = 0
   ElseIf Not (bFindRow) _
   Then
      getItemLocation = Cell.Column
   Else
      getItemLocation = Cell.Row
   End If
   Set Cell = Nothing

End Function
0