Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 411
  • Last Modified:

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

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
tonyantony
Asked:
tonyantony
1 Solution
 
gowflowCommented:
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
 
krishnakrkcCommented:
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
 
tonyantonyAuthor Commented:
Thanks , i have test it , excellent work
you save me many hours of work
0

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now