Re-arrange Data

D

DickKorn

New Member
Joined
May 31, 2017
Messages
6
I have an Excel 2010 workbook where I combined mailing lists from three sources. Each line in the workbook contained an email address, a code indicating the original source list and other information associated with the address. [TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Code[/TD]
[TD]Address[/TD]
[TD]Fld 1[/TD]
[TD]Fld 2[/TD]
[TD]Fld3[/TD]
[/TR]
[TR]
[TD]R[/TD]
[TD]abc@gmail.com[/TD]
[TD]x[/TD]
[TD][/TD]
[TD]X[/TD]
[/TR]
[TR]
[TD]L[/TD]
[TD][TABLE="width: 500"]
<tbody>[TR="class: grid"]
[TD]abc@gmail.com[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]M[/TD]
[TD][TABLE="width: 500"]
<tbody>[TR="class: grid"]
[TD]abc@gmail.com[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]R[/TD]
[TD]xyz@yahoo.com[/TD]
[TD]x[/TD]
[TD][/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]L[/TD]
[TD]xyz@yahoo.com[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]M[/TD]
[TD]sde@aol.com[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I have sorted on email address and discovered duplicate addresses. My goal is to have one line per email address with fields for Code and other fields merged as below:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Address[/TD]
[TD]R[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]Fld1[/TD]
[TD]Fld2[/TD]
[TD]Fld3[/TD]
[/TR]
[TR]
[TD]abc@gmail.com[/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]xyz@yahoo.com[/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD][/TD]
[TD]x[/TD]
[TD][/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]sde@aol.com[/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD]x[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

and a macro to automate the process.
****** id="cke_pastebin" style="position: absolute; top: 86px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">[TABLE="width: 500"]
<tbody>[TR]
[TD]abc@gmail.com[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
Try this for results starting "G1".
Code: 
[COLOR="Navy"]Sub[/COLOR] MG31May51
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng2 [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray(), ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Rng2 = Union(Rng, Range("C1:E1"))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng2
    [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        ReDim Preserve Ray(1 To Rng.Count, 1 To c)
        Ray(1, 1) = "Address"
        Ray(1, c) = Dn.Value
        .Add (Dn.Value), c
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
c = 1
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Offset(, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Ray(c, 1) = Dn.Value
        Ray(c, .Item(Dn.Offset(, -1).Value)) = "x"
        [COLOR="Navy"]For[/COLOR] ac = 1 To 3
            [COLOR="Navy"]If[/COLOR] UCase(Dn.Offset(, ac)) = "X" [COLOR="Navy"]Then[/COLOR]
                Ray(c, .Item(Rng(1).Offset(-1, 1 + ac).Value)) = "x"
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] ac
        Dic.Add (Dn.Value), c
    [COLOR="Navy"]Else[/COLOR]
        Ray(Dic(Dn.Value), .Item(Dn.Offset(, -1).Value)) = "x"
        [COLOR="Navy"]For[/COLOR] ac = 1 To 3
            [COLOR="Navy"]If[/COLOR] UCase(Dn.Offset(, ac)) = "X" [COLOR="Navy"]Then[/COLOR]
                Ray(Dic(Dn.Value), .Item(Rng(1).Offset(-1, 1 + ac).Value)) = "x"
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] ac
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
Range("G1").Resize(Dic.Count + 1, .Count + 1).Value = Ray
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Straight vba

Code: 
Sub rearrangeData()
Dim sh1 As Worksheet, sh2 As Worksheet, fn As Range, c As Range, fAdr As String, col As Long
Set sh1 = Sheets(1) 'edit sheet name
Set sh2 = Sheets(2) 'edit sheet name
sh1.Range("B2", sh1.Cells(Rows.Count, 2).End(xlUp)).AdvancedFilter xlFilterCopy, , sh1.Cells(Rows.Count, 1).End(xlUp)(3), True
    For Each c In sh1.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1)
        If c <> "" Then
        Set fn = sh1.Range("B:B").Find(c.Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                r = sh2.Cells(Rows.Count, 1).End(xlUp)(2).Row
                fAdr = fn.Address
                Do
                    Select Case fn.Offset(0, -1).Value
                        Case "R": col = 2
                        Case "L": col = 3
                        Case "M": col = 4
                    End Select
                    With sh2
                        .Cells(r, 1) = fn.Value
                        .Cells(r, col) = fn.Offset(, -1).Value
                        If fn.Offset(, 1) <> "" Then
                            .Cells(r, 5) = fn.Offset(, 1).Value
                        End If
                        If fn.Offset(, 2) <> "" Then
                            .Cells(r, 6) = fn.Offset(, 2).Value
                        End If
                        If fn.Offset(, 3) <> "" Then
                            .Cells(r, 7) = fn.Offset(, 3)
                        End If
                    End With
                    Set fn = sh1.Range("B:B").FindNext(fn)
                Loop While fAdr <> fn.Address
            End If
            End If
    Next
    sh1.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.ClearContents
End Sub
 
Last edited:
Upvote 0
Thank you. What changes in the code would I have to make if the number of Flds was 15 and not 3,as in the simple example provided?
 
Upvote 0
Code: 
Sub rearrangeData2()
Dim sh1 As Worksheet, sh2 As Worksheet, fn As Range, c As Range, fAdr As String, col As Long, i As Long
Set sh1 = Sheets(1) 'edit sheet name
Set sh2 = Sheets(2) 'edit sheet name
sh1.Range("B2", sh1.Cells(Rows.Count, 2).End(xlUp)).AdvancedFilter xlFilterCopy, , sh1.Cells(Rows.Count, 1).End(xlUp)(3), True
    For Each c In sh1.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1)
        If c <> "" Then
        Set fn = sh1.Range("B:B").Find(c.Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                r = sh2.Cells(Rows.Count, 1).End(xlUp)(2).Row
                fAdr = fn.Address
                Do
                    Select Case fn.Offset(0, -1).Value
                        Case "R": col = 2
                        Case "L": col = 3
                        Case "M": col = 4
                    End Select
                   [COLOR=#ff8c00] sh2.Cells(r, 1) = fn.Value
                    sh2.Cells(r, col) = fn.Offset(, -1).Value
                    For i = 3 To sh1.Cells(fn.Row, Columns.Count).End(xlToLeft).Column
                        If sh1.Cells(fn.Row, i) <> "" Then
                            sh2.Cells(r, i + 2) = sh1.Cells(fn.Row, i).Value
                        End If
                    Next[/COLOR]
                    Set fn = sh1.Range("B:B").FindNext(fn)
                Loop While fAdr <> fn.Address
            End If
            End If
    Next
    sh1.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.ClearContents
End Sub
 
Last edited:
Upvote 0
Try this:-
Run this code on your data sheet for results on sheet2 starting "A1".
This code is for data with multi-columns.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG01Jun59
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng2 [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray(), ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] AcRng
[COLOR="Navy"]Set[/COLOR] AcRng = Range(Range("c1"), Cells(1, Columns.Count).End(xlToLeft))
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Rng2 = Union(Rng, AcRng)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng2
    [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        ReDim Preserve Ray(1 To Rng.Count, 1 To c)
        Ray(1, 1) = "Address"
        Ray(1, c) = Dn.Value
        .Add (Dn.Value), c
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
c = 1
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Offset(, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Ray(c, 1) = Dn.Value
        Ray(c, .Item(Dn.Offset(, -1).Value)) = "X"
        [COLOR="Navy"]For[/COLOR] ac = 1 To AcRng.Count
            [COLOR="Navy"]If[/COLOR] UCase(Dn.Offset(, ac)) = "X" [COLOR="Navy"]Then[/COLOR]
                Ray(c, .Item(Rng(1).Offset(-1, 1 + ac).Value)) = "X"
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] ac
        Dic.Add (Dn.Value), c
    [COLOR="Navy"]Else[/COLOR]
        Ray(Dic(Dn.Value), .Item(Dn.Offset(, -1).Value)) = "X"
        [COLOR="Navy"]For[/COLOR] ac = 1 To AcRng.Count
            [COLOR="Navy"]If[/COLOR] UCase(Dn.Offset(, ac)) = "X" [COLOR="Navy"]Then[/COLOR]
                Ray(Dic(Dn.Value), .Item(Rng(1).Offset(-1, 1 + ac).Value)) = "X"
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] ac
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(Dic.Count + 1, .Count + 1)
     .Value = Ray
     .Borders.Weight = 2
     .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
VBA script to insert new rows based on data in other cells... then cut data from those cells and paste into those new rows
Replies
6
Views
1K
mbnnyc
M
N
  • Question Question
Delete not necessary column and rearrange column
Replies
1
Views
641
SpillerBD
S
B
  • Solved
VBA code to re-arrange the data based on date and zone.
Replies
5
Views
834
maabadi
M
T
  • Question Question
Copy Data with transpose to Sheet2 from Sheet1 between 2 email address.
Replies
4
Views
791
Fluff
Fluff
U
  • Question Question
VBA: Exclude Data Based on Date
Replies
5
Views
3K
mumps
mumps

Forum statistics

Threads
1,224,759
Messages
6,180,813
Members
452,996
Latest member
nelsonsix66

Share this page

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