Solved

merge cells (on a Excell sheet) of selected columns , and only the duplicated values with the sign ; in between the merged cells!

Posted on 2013-01-19
3
388 Views
Last Modified: 2013-01-20
merge cells (on a Excell sheet) of selected columns , and only the duplicated values with the sign ; in between the merged cells!

I want to merge cells on excel 2007  but the conditions are :
      1.  only from 2 selected columns of a sheet say "AA"  &  "BF",
           independent of the number of columns. IN starting row "2"
      2.  Find only the duplicated values on the "AA" and merge only the opposite value          (the other value right or left)
      3.  with a sign ";" in "red" color between the merged values in the cell
      4.  the values  to be in <<orange>> the 2nd , in <<blue>> the 3rd ,the 4rth in ......
      5.  and bold all of the cell values that is merged      
      6.  clear content & highlight with background color with in row after merged
      7.  stop macro when in "AA" column   finds cell that is empty.

I have  26 columns , 8000 rows  of data
thanks anyone that helps
see example
merge-dup-cell---compare2.xlsx
0
Comment
Question by:tonyantony
3 Comments
 
LVL 29

Expert Comment

by:gowflow
ID: 38796764
Can we give you the result in a separate sheet ? as here u have them in the same sheet. also what are the colors afterthe 3rd you put ... ? we chose a diffrent color you mean ???
Don't you think that the colors + background yellow is a bit too much to distinguish the colors ?? If you don't mind I would decide either
Keep the yellow baground and not put colors by duplicate

OR

Remove the yellow background and keep the colors by duplicate.

Last but not least I presume what you want is to select the 2 columns and then press on a button and the macro will produce the results based on what you selected. Is that right ?

Pls advise.
gowflow
0
 
LVL 18

Accepted Solution

by:
krishnakrkc earned 500 total points
ID: 38797880
Hi


Sub kTest()
    
    Dim FC, MC, i As Long, Colors, x, n As Long, c As Long
    Dim dic As Object, MergeCol As Range, j As Long, MRC, MRA As String
    
    Colors = Array(0, 16711680, 5287936, 13369446, 49407) '<< add more colors
    
    Const FirstCol = "B"    '<< adjust to suit
    Const MyRangeAddress = "A:F"   '<< adjust to suit
    
    Set MergeCol = Application.InputBox("Select the Range to be MERGED", Type:=8)
    
    With MergeCol
        MRA = .Parent.Range(CStr(Split(MyRangeAddress, ":")(0) & .Row & ":" & _
                        Split(MyRangeAddress, ":")(1) & .Row + .Rows.Count - 1)).Address
        MRC = .Parent.Range(MRA).Value2
        FC = .Parent.Range(FirstCol & .Row).Resize(.Rows.Count).Value2
    End With
    
    MC = MergeCol.Value2
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    For i = UBound(FC, 1) To 1 Step -1
        If Len(FC(i, 1)) Then
            If Not dic.exists(FC(i, 1)) Then
                dic.Item(FC(i, 1)) = i
            Else
                j = dic.Item(FC(i, 1))
                For c = 1 To UBound(MRC, 2)
                    MRC(j, c) = Empty
                Next
                MC(i, 1) = MC(i, 1) & ";" & MC(j, 1)
                MC(j, 1) = Empty
                dic.Item(FC(i, 1)) = i
            End If
        End If
    Next
    
    MergeCol.Parent.Range(MRA) = MRC
    
    With MergeCol
        .Value = MC
        For i = 1 To UBound(MC, 1)
            If InStr(1, MC(i, 1), ";") Then
                x = Split(MC(i, 1), ";")
                With .Cells(i, 1)
                    n = 1: c = 0
                    For j = 0 To UBound(x)
                        If j > UBound(Colors) Then c = 0
                        .Characters(n, Len(x(j))).Font.Color = Colors(c)
                        .Characters(Len(x(j)) + n, 1).Font.Color = 255
                        n = n + Len(x(j)) + 1
                        c = c + 1
                    Next
                    .Font.Size = 12
                    .Font.Bold = True
                    .Interior.Color = vbYellow
                End With
            End If
        Next
    End With
    
End Sub

Open in new window


Kris
0
 

Author Closing Comment

by:tonyantony
ID: 38799346
Thanks , i have test it , excellent work
you save me many hours of work
0

Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

840 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question