Need a solution to club data from multiple columns and prepare a unique list

[Siddhu11011]

I have couple of columns in which accounts and account names are listed as below. I just need a solution to consolidate data from front 6 columns into last 2 columns.
ex: 1st, 3rd, and 5th columns are combined into 2nd last column and likewise for Account Names. Last 2 columns are having unique list of line items.
It would be helpful and delighted moment for me if you could just guide me with appropriate solution.

Account Number	Account Name	Account Number	Account Name	Account Number	Account Name	→	Account Number	Account Name
1254	Shahid	12458	Taylor	cadda3333	Dinesh		1254	Shahid
D148	Rahil	df5846	Reyon	Ssd54	Suresh		D148	Rahil
1496	Sajid	aw2546f	Rajesh	sDs54	Michel		1496	Sajid
D148	Rahil	aasf21531	Ramesh	asds655	Tom		12458	Taylor
		ASas131	Saira	cadda3333	Dinesh		df5846	Reyon
		xazcsd32123	Kiara				aw2546f	Rajesh
		ss31	Jenish				aasf21531	Ramesh
		aasd131	Pankit				ASas131	Saira
		df5846	Reyon				xazcsd32123	Kiara
		aw2546f	Rajesh				ss31	Jenish
							aasd131	Pankit
							cadda3333	Dinesh
							Ssd54	Suresh
							sDs54	Michel
							asds655	Tom

 

[kevin9999]

Try this:

Option Explicit
Sub Siddhu11011_V7()
    Application.ScreenUpdating = False
    
    '   Clear columns AC:AD of data
    Range("AC2:AD" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
    
    '   Copy data to columns AC:AD
    Dim LRow As Long, Source
    Range("AC1").Resize(1, 2).Value = Array("Account Number", "Account Name")
    LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    For Each Source In Array("B2", "K2", "T2")
        With ActiveSheet.Range(Source).SpillingToRange
            Range("AC" & LRow).Resize(.Rows.Count, 2) = .Value
        End With
        LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    Next Source
    
    '   Remove the duplicates
    Range("AC:AD").RemoveDuplicates Columns:=2, Header:=xlYes
    Range("AC1").Select
    Application.ScreenUpdating = True
End Sub

 

[Siddhu11011]

Do you get those other columns from the same Filter function that returns the Account names and numbers?

Yes, data of all three tables get auto populated

 

[kevin9999]

Yes, data of all three tables get auto populated

Try the code in post #21 and let me know how it goes.

 

[Siddhu11011]

Try this:

Option Explicit
Sub Siddhu11011_V7()
    Application.ScreenUpdating = False
 
    '   Clear columns AC:AD of data
    Range("AC2:AD" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
 
    '   Copy data to columns AC:AD
    Dim LRow As Long, Source
    Range("AC1").Resize(1, 2).Value = Array("Account Number", "Account Name")
    LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    For Each Source In Array("B2", "K2", "T2")
        With ActiveSheet.Range(Source).SpillingToRange
            Range("AC" & LRow).Resize(.Rows.Count, 2) = .Value
        End With
        LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    Next Source
 
    '   Remove the duplicates
    Range("AC:AD").RemoveDuplicates Columns:=2, Header:=xlYes
    Range("AC1").Select
    Application.ScreenUpdating = True
End Sub

Try the code in post #21 and let me knoI need

Try the code in post #21 and let me know how it goes.

It goes very well. One last help please please - Can you remove column headings for AC1 and AD1 which are account number and name?

 

[kevin9999]

One last help please please - Can you remove column headings for AC1 and AD1 which are account number and name?

This should do it.

Option Explicit
Sub Siddhu11011_V8()
    Application.ScreenUpdating = False
    
    '   Clear columns AC:AD of data
    Range("AC1:AD" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
    
    '   Copy data to columns AC:AD
    Dim LRow As Long, Source
    Range("AC1").Resize(1, 2).Value = Array("Account Number", "Account Name")
    LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    For Each Source In Array("B2", "K2", "T2")
        With ActiveSheet.Range(Source).SpillingToRange
            Range("AC" & LRow).Resize(.Rows.Count, 2) = .Value
        End With
        LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    Next Source
    
    '   Remove the duplicates
    Range("AC:AD").RemoveDuplicates Columns:=2, Header:=xlYes
    Range("AC1:AD1").ClearContents
    Application.ScreenUpdating = True
End Sub

 

[Siddhu11011]

This should do it.

Option Explicit
Sub Siddhu11011_V8()
    Application.ScreenUpdating = False
   
    '   Clear columns AC:AD of data
    Range("AC1:AD" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
   
    '   Copy data to columns AC:AD
    Dim LRow As Long, Source
    Range("AC1").Resize(1, 2).Value = Array("Account Number", "Account Name")
    LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    For Each Source In Array("B2", "K2", "T2")
        With ActiveSheet.Range(Source).SpillingToRange
            Range("AC" & LRow).Resize(.Rows.Count, 2) = .Value
        End With
        LRow = Columns("AC:AC").Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row + 1
    Next Source
   
    '   Remove the duplicates
    Range("AC:AD").RemoveDuplicates Columns:=2, Header:=xlYes
    Range("AC1:AD1").ClearContents
    Application.ScreenUpdating = True
End Sub

You are a Rockstar! What a concreate solution. Thank you so much for treating me patiently and your great help!

 

[kevin9999]

You are a Rockstar! What a concreate solution. Thank you so much for treating me patiently and your great help!

Glad we got there in the end, and thanks for the feedback