Excel1: Complex Macro.

aacod

Well-known Member
Joined
Mar 20, 2009
Messages
667
Under column A from cells 2 to 85000 I have multiple duplicate entries: e.g. INT, INT, INT.
In the corresponding cells under column B for all the INT, it means Internal, International, Interval.

I need a macro that would identify all duplicate entries in Column A, copy the contents from corresponding cells in column B and paste to one of the cells corresponding to ‘INT’ in column B separated by ‘Or’. e.g. as follows:


Sheet1

*
A
B
C
D
E
1
*
*
*
*
*
2
*
*
*
Befor Macro
*
3
*
*
*
*
*
4
INT
Internal
*
*
*
5
INT
International
*
*
*
6
INT
Interval
*
*
*
7
*
*
*
*
*
8
*
*
*
After Macro
*
9
*
*
*
*
*
10
INT
Internal or International or Interval
*
*
*
11
*
*
*
*
*
12
*
*
*
*
*
13
*
*
*
*
*
14
*
*
*
*
*

<tbody>
</tbody>


Excel tables to the web >> Excel Jeanie Html" target="_blank"> Excel Jeanie HTML 4
 
Last edited:

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Hi Aacod,
Try this:
Code:
Sub MergeMultipleMeanings()
Dim Cell As Range, Cel As Range, Sc As String, OrS As String
Sc = "B2"
OrS = " or "
For Each Cell In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If Cell.Value <> Cell.Offset(1, 0).Value Then
        If Cell.Offset(0, 1).Address(0, 0) <> Sc Then
            For Each Cel In Range(Sc, Cell.Offset(0, 1).Address(0, 0))
                Range(Sc).Value = Range(Sc).Value & OrS & Cel.Value
                If Cel.Address(0, 0) <> Sc Then
                    Cel.Value = ""
                    Cel.Offset(0, -1).Value = ""
                End If
            Next
            Range(Sc).Value = Mid(Range(Sc).Value, InStr(1, Range(Sc).Value, OrS) + 4)
        End If
        Sc = Cell.Offset(1, 1).Address(0, 0)
    End If
Next
End Sub
Note that this code will keep blank cells in your table so notify me if you want me to add some lines to delete your empty cells.
ZAX
 
Upvote 0
ZAX,

I think you have the idea what I want to achieve. I tried the macro provided and I have posted the result. Example 3 is what I want to achieve. The blank line in Example 1 have single Acronyms, those should stay as is. Blank row(s) created after running macro should get deleted. Range A2:A85000 and B2:B85000 rows.

Example 1: Before Macro

Sheet1

*ABCDE
1*Before Macro***
2*****
3wrtwith regards to***
4i.e.that is***
5IntInterval***
6*****
7IntInternational***
8IntInternal***
9*****
10*****
11IntInteger***
12*****
13*****
14TempTemporary***
15TempTemperature***
16*****
17tempTemparament***
18*****
19*****
20INTIntuit***
21*****
22*****
23*****

<colgroup><col style="width: 30px; font-weight: bold;"><col style="width: 64px;"><col style="width: 101px;"><col style="width: 64px;"><col style="width: 64px;"><col style="width: 64px;"></colgroup><tbody>
</tbody>


Excel tables to the web >> Excel Jeanie Html" target="_blank"> Excel Jeanie HTML 4


Example 2: Current Macro does following:

Sheet1

*ABCD
1*Current Macro does following**
2****
3wrtwith regards to**
4i.e.that is**
5IntInterval**
6****
7IntInternational or Internal**
8****
9* or **
10****
11IntInteger**
12* or **
13****
14TempTemporary or Temperature**
15****
16****
17tempTemparament**
18* or **
19****
20INTIntuit**
21****
22****

<colgroup><col style="width: 30px; font-weight: bold;"><col style="width: 64px;"><col style="width: 194px;"><col style="width: 64px;"><col style="width: 64px;"></colgroup><tbody>
</tbody>


Excel tables to the web >> Excel Jeanie Html" target="_blank"> Excel Jeanie HTML 4


Example 3: I want the result as follows:
Sheet1

*AB
1*After Macro Run
2**
3wrtwith regards to
4i.e.that is
5IntInterval or International or Internal or Integer or Intuit
6TempTemporary or Temperature or Temparament
7**
8**

<colgroup><col style="width: 30px; font-weight: bold;"><col style="width: 64px;"><col style="width: 349px;"></colgroup><tbody>
</tbody>


Excel tables to the web >> Excel Jeanie Html" target="_blank"> Excel Jeanie HTML 4

I hope I am clear in explaning.

Thanks.

aacod
 
Last edited:
Upvote 0
See if this does what you want. Results are written to columns E:F.
Test in a copy of your workbook.
Rich (BB code):
Sub Combine_Results()
  Dim a As Variant
  Dim d1 As Object, d2 As Object
  Dim i As Long, UBa As Long
  Dim s1 As String, s2 As String
  
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  UBa = UBound(a, 1)
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For i = 1 To UBa
    s1 = LCase(a(i, 1))
    If Len(s1) Then
      s2 = LCase(a(i, 2))
      If d1.exists(s1) Then
        If Not d2.exists(s2) Then
          d2.Add s2, s2
          d1.Item(s1) = d1.Item(s1) & " or " & s2
        End If
      Else
        d1.Add s1, s2
        d2.Add s2, s2
      End If
    End If
  Next i
  Range("E2").Resize(d1.Count, 2).Value = Application.Transpose(Array(d1.keys, d1.items))
End Sub
 
Upvote 0
Peter,

The code works perfect to the example I provided, but gives me following ERROR on the workbook where I want it to function:

'This key is already associated with an element of this collection'.

I do not have any code except the one provided and pasted by you in the workbook.

aacod
 
Upvote 0
The code works perfect to the example I provided, but gives me following ERROR on the workbook where I want it to function:

'This key is already associated with an element of this collection'.
Yes, I wondered if that would happen. That is caused by the same term in column B having different terms in column A on different rows.
I haven't tested this greatly, but give it a try,
Rich (BB code):
Sub Combine_Results_2()
  Dim a As Variant, b As Variant
  Dim i As Long, UBa As Long, j As Long, k As Long
  Dim s1 As String, s2 As String
  
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  UBa = UBound(a, 1)
  ReDim b(1 To UBa, 1 To 2)
  k = 0
  For i = 1 To UBa
    s1 = LCase(a(i, 1))
    If Len(s1) Then
      s2 = LCase(a(i, 2))
      j = 1
      Do Until b(j, 1) = s1 Or j > k
        j = j + 1
      Loop
      If j > k Then
        k = k + 1
        b(k, 1) = s1
        b(k, 2) = "|" & s2 & "|"
      Else
        If InStr(1, b(j, 2), "|" & s2 & "|") = 0 Then
          b(j, 2) = b(j, 2) & s2 & "|"
        End If
      End If
    End If
  Next i
  For i = 1 To k
    b(i, 2) = Replace(Mid(b(i, 2), 2, Len(b(i, 2)) - 2), "|", " or ", 1, -1, 1)
  Next i
  Range("E2").Resize(k, 2).Value = b
End Sub
 
Upvote 0
Peter,

Sorry for getting back late.

The macro works PERFECT.

Though, if possible, I need some more refinement as follows:

1. Width of column F must be 90 pixels.
2. First character of each word in column F must be in upper case.
3. No more than 8 words must fit in a row (90 pixel) in column F, if more than 8 create another row and paste in the newly created row, if more than 8 in 2nd row, create 3rd row and paste in 3rd row etc; e.g.

INT Interval or Integer or International or 4 or 5 or 6 or 7 or 8 or

INT Intent or 10 or 11 or 12 ..............

where 4 to 12 represent words.

HTH.

Thanks.
 
Upvote 0
I am sorry but something has come up and I will not be able to give any time to the forum for the next 6-8 days. I will look at this again after that and try to assist if a solution has not been found.
 
Upvote 0
Though, if possible, I need some more refinement as follows:

1. Width of column F must be 90 pixels.
2. First character of each word in column F must be in upper case.
3. No more than 8 words must fit in a row (90 pixel) in column F, if more than 8 create another row and paste in the newly created row, if more than 8 in 2nd row, create 3rd row and paste in 3rd row etc; e.g.

INT Interval or Integer or International or 4 or 5 or 6 or 7 or 8 or

INT Intent or 10 or 11 or 12 ..............

where 4 to 12 represent words.

HTH.

Thanks.
I'm leaving the column width to you.
See if this deals with the other issues as you want.
Rich (BB code):
Sub Combine_Results_3()
  Dim a As Variant, b As Variant, c As Variant, Bits As Variant
  Dim i As Long, UBa As Long, j As Long, k As Long, x As Long, y As Long
  Dim s1 As String, s2 As String, tmp As String
  
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  UBa = UBound(a, 1)
  ReDim b(1 To UBa, 1 To 2)
  ReDim c(1 To UBa, 1 To 2)
  k = 0
  For i = 1 To UBa
    s1 = LCase(a(i, 1))
    If Len(s1) Then
      s2 = LCase(a(i, 2))
      j = 1
      Do Until b(j, 1) = s1 Or j > k
        j = j + 1
      Loop
      If j > k Then
        k = k + 1
        b(k, 1) = s1
        b(k, 2) = "|" & s2 & "|"
      Else
        If InStr(1, b(j, 2), "|" & s2 & "|") = 0 Then
          b(j, 2) = b(j, 2) & s2 & "|"
        End If
      End If
    End If
  Next i
  For i = 1 To k
    Bits = Split(Mid(b(i, 2), 2, Len(b(i, 2)) - 2), "|")
    x = 0
    tmp = vbNullString
    For j = 0 To UBound(Bits)
      x = x + 1
      tmp = tmp & " or " & WorksheetFunction.Proper(Bits(j))
      If x = 8 Or j = UBound(Bits) Then
        y = y + 1
        c(y, 1) = b(i, 1)
        c(y, 2) = Mid(tmp, 5)
        tmp = vbNullString
        x = 0
      End If
    Next j
  Next i
  Range("E2").Resize(y, 2).Value = c
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,293
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top