Excel: Merge adjacent rows if they contain the same values Closed

Question

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.

rizvisa1 · Answer

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

Zohaib R · Answer

Hi kobe1121,

There is a similar solution that will help. I hope this will give you an idea as to how to write the desired macro:

1.	Open a new Excel Sheet.
2.	Enter the following values:
A1 - Date
B1 - Name
C1 - ID
D1 - Text
3.	Fill the columns with the desired data.
4.	Click File in the top menu of the Excel, Select Options and then Customize ribbon, from the right pane check Developer and then click OK.
5.	Click Home and go to the original excel sheet.
6.	Click Developer from the top Menu.
7.	Click Insert and then select command button from the ActiveX Controls.
8.	Draw a button in a convenient location on the Excel Sheet.
9.	Click Design Mode and then double click the button, it will open the Macro Editing window.
10.	Paste the below code in the window:

Dim d As Date, r As Long, n As Integer, c As Range

For r = 1 To Cells(Rows.Count, 3).End(xlUp).Row - 1
    If Int(Cells(r, 3)) = Int(Cells(r + 1, 3)) Then
        n = n + 1
    End If
    If Int(Cells(r, 3)) <> Int(Cells(r + 1, 3)) And n > 0 Then
        For Each c In Range(Cells(r - n + 1, 3), Cells(r, 3))
            c.Font.ColorIndex = 2
            c.Interior.ColorIndex = 2
        Next c
        Range(Cells(r - n, 3), Cells(r, 3)).BorderAround ColorIndex:=3, Weight:=xlThin
        n = 0
    End If
Next r

11.	Close the Macro Editing window go back to the excel sheet.
12.	Again click design mode.
13.	Now click on the button you created it will format the data in the 3rd column.

Steps 4 through 6 are valid for Excel 2010, for earlier versions of Excel these steps might differ.

Do reply if you need any further help or clarifications.

kobe1121 · Answer

https://www.2shared.com/document/ik2GvQZK/Demo.html

You can download the sample file here. I have also added a complication which looks more like the actual spreadsheet I am working on. Thanks for your help.

kobe1121 · Answer

Thanks rizvisa1 again for your reply, but I have copied those to vba to run, and nothing happened...

kobe1121 · Answer

I have a further complication on this. Help would be greatly appreciated.
When I am using the macro, I have found some problems.
Please download the exhibit here (remove the space)
w w w. 2shared . c o m/file/Hf5RKvLy/Demo.html

I want the macro to merge cells according to one core column ("ID" in the exhibit)
1. Adjacent columns with the same "ID" will be merged
2. When "ID" are the same, the macro will try to merge other columns also: "NAME", "DATE", "CURRENCY"
3. Adjacent columns with same values but not having the same "ID" would not be merged: "CURRENCY" will not be merged if "ID" are not the same

Many many thanks!

Excel: Merge adjacent rows if they contain the same values

5 responses

Similar discussions

Subscribe To Our Newsletter!