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

Siddhu11011 · Sep 23, 2022

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

OaklandJim · Sep 26, 2022

Here is a macro that does exactly what was specified. It gathers data from the first six columns then puts data in the column two over from the last raw data column processed. I used the exact data that you posted. It is pretty long and as usual, better programmers could produce a better macro.

VBA Code:

Sub ConsolidateClubData()

'   Worksheet with data
    Dim wsDataSheet As Worksheet
    
'   Array that holds raw data as it is gathered.
    Dim asAccountInfo() As String

'   Range containing account numbers.
    Dim rAccountNumCol As Range
    
'   Range where results are located.
    Dim rResultsRange As Range
    
'   Range with all results data including headers.
    Dim rSortrange As Range
    
'   Used for looping through data ranges.
    Dim iDataRange As Long
    
'   Count of data ranges.
    Dim iDataRangesCount As Long
    
'   Used for looping through rows in data ranges.
    Dim iDataRowIndex As Long
    
'   Used to keep track of data rows as they are processed.
    Dim iRowsProcessed As Long
    
'   Count of results entries (rows).
    Dim iResultsEntriesCount As Long
    
'   Used to keep track of which raw data column is being processed.
    Dim iRawDataColIndex As Long
    
'   Used to keep track of which results data column is being processed.
    Dim iResultsColIndex As Long
    
'   Used while deleting duplicates in results range to keep track of
'   1. the previous name encountered and 2. which name is being processed.
    Dim sPreviousName As String
    Dim sCurrentName As String
    
'   -----------------------------
'          Initilizations
'   -----------------------------

'   Count of raw data ranges (2 columns each).
    iDataRangesCount = 3
    
'   Results range is two columns to the right of raw data.
    iResultsColIndex = (iDataRangesCount * 2) + 2
    
'   Initial sizing of array.
    ReDim asAccountInfo(2, 1)
    
'   Data is presumed to be in the first worksheet.
    Set wsDataSheet = ThisWorkbook.Worksheets(1)
    
'   Initialize rows processed counter.
    iRowsProcessed = 0
    
    With wsDataSheet
    
'       Location for results, two columns wide.
        Set rResultsRange = .Columns(iResultsColIndex).Resize(, 2).EntireColumn
        
'       Clear existing data from results range (all rows in the columns).
        rResultsRange.Value = ""
        
'       ----------------------------------------
'             Processing Raw Data Ranges
'       ----------------------------------------
        
'       Loop all data ranges and fill array with values.
        For iDataRange = 1 To iDataRangesCount
            
'           Raw data column 1 index.
            iRawDataColIndex = (iDataRange * 2) - 1
            
'           Set range where account numbers are located for the current raw
'           data range being processed.
            Set rAccountNumCol = .Columns(iRawDataColIndex).EntireColumn

            iDataRowIndex = 0

'           Loop current raw data range until an empty cell is encountered.
            While rAccountNumCol.Cells(iDataRowIndex + 1) <> ""
            
                iDataRowIndex = iDataRowIndex + 1
                                
'               ----------------------------
'                    Put Data into Array
'               ----------------------------

'               Don't put raw data column's headers into the array.
                If Not UCase(rAccountNumCol.Cells(iDataRowIndex)) Like "*ACCOUNT*" _
                 Then
                    iRowsProcessed = iRowsProcessed + 1
                                    
                    ReDim Preserve asAccountInfo(2, iRowsProcessed)
                    asAccountInfo(1, iRowsProcessed) = rAccountNumCol.Cells(iDataRowIndex).Value
                    asAccountInfo(2, iRowsProcessed) = rAccountNumCol.Cells(iDataRowIndex).Offset(0, 1).Value
                    
                End If
                            
            Wend
                                    
        Next
        
'      -------------------------------------
'          Put Headers into 2 top cells
'      -------------------------------------

'       Put column headers into results range
        With .Columns(iResultsColIndex)
            .Cells(1, 1).Value = "Account Number"
            .Cells(1, 2).Value = "Account Name"
        End With
        
        iResultsEntriesCount = UBound(asAccountInfo, 2)
        
'       Reset range var to point to range where array data is placed.
        Set rResultsRange = .Columns(iResultsColIndex).Cells(2).Resize(iResultsEntriesCount, 2)
    
'       Put the array data into the results data range.
        rResultsRange.Value = Application.Transpose(asAccountInfo)
        
'       ---------------------------------
'                Sort results
'       ---------------------------------
        
'       Set sort range to point to names data without headers.
        Set rSortrange = .Columns(iResultsColIndex + 1).Cells(2).Resize(iResultsEntriesCount, 1)
        
'       Reset results range var to point to range for results data including headers.
        Set rResultsRange = .Columns(iResultsColIndex).Cells(1).Resize(iResultsEntriesCount + 1, 2)

        With .Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=rSortrange _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

            .SetRange rResultsRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply

        End With
    
'       ---------------------------------
'               Delete duplicates
'       ---------------------------------
        
'       Reset range var to point to range with results data without headers.
        Set rResultsRange = .Columns(iResultsColIndex).Cells(2).Resize(iResultsEntriesCount, 2)
        
    End With 'wsDataSheet
        
'   First iteration set previous name = "".
    sPreviousName = ""

'   Step through results, backwards, to delete rows with duplicate entries.
    For iDataRowIndex = iResultsEntriesCount To 1 Step -1
        
'       Set current name to compare with previous name.
        sCurrentName = rResultsRange.Cells(iDataRowIndex, 2).Value
            
        If sCurrentName = sPreviousName _
         Then
         
'           Delete the 2 column row data (duplicate).
            rResultsRange.Cells(1).Offset(iDataRowIndex - 1).Resize(1, 2).Delete Shift:=xlUp

        End If

'       Set previous name for next iteration.
        sPreviousName = rResultsRange.Cells(iDataRowIndex, 2).Value
    
    Next iDataRowIndex
    
End Sub

kevin9999 · Sep 26, 2022

Another option. Assumes the macro is run with the sheet active, and that your data starts in Column A, with row 1 being headers.

VBA Code:

Option Explicit
Sub Siddhu11011()
    Application.ScreenUpdating = False
    
    '   Clear columns H:I of data
    Range("H2:I" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
    
    '   Load the input array
    Dim ArrIn(1 To 3)
    Dim i As Long, j As Long, LRow As Long, TotRows As Long
    j = 1
    For i = 1 To 3
        LRow = Columns(j).Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row
        ArrIn(i) = Cells(2, j).Resize(LRow - 1, 2)
        TotRows = TotRows + UBound(ArrIn(i), 1)
        j = j + 2
    Next i
    
    '   Load the output array
    Dim r As Long, rw As Long, col As Long, arr
    ReDim ArrOut(1 To TotRows, 1 To 2)
    r = 1
    For i = 1 To 3
        arr = ArrIn(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                ArrOut(r, col) = arr(rw, col)
            Next col
            r = r + 1
        Next rw
    Next i
    
    '   Return the output array to the sheet & remove the duplicates
    Range("H2").Resize(UBound(ArrOut, 1), 2).Value = ArrOut
    Range("H:I").RemoveDuplicates Columns:=2, Header:=xlYes
    Application.ScreenUpdating = True
    
End Sub

Siddhu11011 · Sep 27, 2022

OaklandJim said:

Here is a macro that does exactly what was specified. It gathers data from the first six columns then puts data in the column two over from the last raw data column processed. I used the exact data that you posted. It is pretty long and as usual, better programmers could produce a better macro.

VBA Code:

Sub ConsolidateClubData()

'   Worksheet with data
    Dim wsDataSheet As Worksheet
   
'   Array that holds raw data as it is gathered.
    Dim asAccountInfo() As String

'   Range containing account numbers.
    Dim rAccountNumCol As Range
   
'   Range where results are located.
    Dim rResultsRange As Range
   
'   Range with all results data including headers.
    Dim rSortrange As Range
   
'   Used for looping through data ranges.
    Dim iDataRange As Long
   
'   Count of data ranges.
    Dim iDataRangesCount As Long
   
'   Used for looping through rows in data ranges.
    Dim iDataRowIndex As Long
   
'   Used to keep track of data rows as they are processed.
    Dim iRowsProcessed As Long
   
'   Count of results entries (rows).
    Dim iResultsEntriesCount As Long
   
'   Used to keep track of which raw data column is being processed.
    Dim iRawDataColIndex As Long
   
'   Used to keep track of which results data column is being processed.
    Dim iResultsColIndex As Long
   
'   Used while deleting duplicates in results range to keep track of
'   1. the previous name encountered and 2. which name is being processed.
    Dim sPreviousName As String
    Dim sCurrentName As String
   
'   -----------------------------
'          Initilizations
'   -----------------------------

'   Count of raw data ranges (2 columns each).
    iDataRangesCount = 3
   
'   Results range is two columns to the right of raw data.
    iResultsColIndex = (iDataRangesCount * 2) + 2
   
'   Initial sizing of array.
    ReDim asAccountInfo(2, 1)
   
'   Data is presumed to be in the first worksheet.
    Set wsDataSheet = ThisWorkbook.Worksheets(1)
   
'   Initialize rows processed counter.
    iRowsProcessed = 0
   
    With wsDataSheet
   
'       Location for results, two columns wide.
        Set rResultsRange = .Columns(iResultsColIndex).Resize(, 2).EntireColumn
       
'       Clear existing data from results range (all rows in the columns).
        rResultsRange.Value = ""
       
'       ----------------------------------------
'             Processing Raw Data Ranges
'       ----------------------------------------
       
'       Loop all data ranges and fill array with values.
        For iDataRange = 1 To iDataRangesCount
           
'           Raw data column 1 index.
            iRawDataColIndex = (iDataRange * 2) - 1
           
'           Set range where account numbers are located for the current raw
'           data range being processed.
            Set rAccountNumCol = .Columns(iRawDataColIndex).EntireColumn

            iDataRowIndex = 0

'           Loop current raw data range until an empty cell is encountered.
            While rAccountNumCol.Cells(iDataRowIndex + 1) <> ""
           
                iDataRowIndex = iDataRowIndex + 1
                               
'               ----------------------------
'                    Put Data into Array
'               ----------------------------

'               Don't put raw data column's headers into the array.
                If Not UCase(rAccountNumCol.Cells(iDataRowIndex)) Like "*ACCOUNT*" _
                 Then
                    iRowsProcessed = iRowsProcessed + 1
                                   
                    ReDim Preserve asAccountInfo(2, iRowsProcessed)
                    asAccountInfo(1, iRowsProcessed) = rAccountNumCol.Cells(iDataRowIndex).Value
                    asAccountInfo(2, iRowsProcessed) = rAccountNumCol.Cells(iDataRowIndex).Offset(0, 1).Value
                   
                End If
                           
            Wend
                                   
        Next
       
'      -------------------------------------
'          Put Headers into 2 top cells
'      -------------------------------------

'       Put column headers into results range
        With .Columns(iResultsColIndex)
            .Cells(1, 1).Value = "Account Number"
            .Cells(1, 2).Value = "Account Name"
        End With
       
        iResultsEntriesCount = UBound(asAccountInfo, 2)
       
'       Reset range var to point to range where array data is placed.
        Set rResultsRange = .Columns(iResultsColIndex).Cells(2).Resize(iResultsEntriesCount, 2)
   
'       Put the array data into the results data range.
        rResultsRange.Value = Application.Transpose(asAccountInfo)
       
'       ---------------------------------
'                Sort results
'       ---------------------------------
       
'       Set sort range to point to names data without headers.
        Set rSortrange = .Columns(iResultsColIndex + 1).Cells(2).Resize(iResultsEntriesCount, 1)
       
'       Reset results range var to point to range for results data including headers.
        Set rResultsRange = .Columns(iResultsColIndex).Cells(1).Resize(iResultsEntriesCount + 1, 2)

        With .Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=rSortrange _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

            .SetRange rResultsRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply

        End With
   
'       ---------------------------------
'               Delete duplicates
'       ---------------------------------
       
'       Reset range var to point to range with results data without headers.
        Set rResultsRange = .Columns(iResultsColIndex).Cells(2).Resize(iResultsEntriesCount, 2)
       
    End With 'wsDataSheet
       
'   First iteration set previous name = "".
    sPreviousName = ""

'   Step through results, backwards, to delete rows with duplicate entries.
    For iDataRowIndex = iResultsEntriesCount To 1 Step -1
       
'       Set current name to compare with previous name.
        sCurrentName = rResultsRange.Cells(iDataRowIndex, 2).Value
           
        If sCurrentName = sPreviousName _
         Then
        
'           Delete the 2 column row data (duplicate).
            rResultsRange.Cells(1).Offset(iDataRowIndex - 1).Resize(1, 2).Delete Shift:=xlUp

        End If

'       Set previous name for next iteration.
        sPreviousName = rResultsRange.Cells(iDataRowIndex, 2).Value
   
    Next iDataRowIndex
   
End Sub

Let me be precise, data is available in columns B, C & K, L & T, U with heading as account number and name respectively. I need a result in columns AC and AD. Can you make changes in above codes?

Siddhu11011 · Sep 27, 2022

kevin9999 said:

Another option. Assumes the macro is run with the sheet active, and that your data starts in Column A, with row 1 being headers.

VBA Code:

Option Explicit
Sub Siddhu11011()
    Application.ScreenUpdating = False
   
    '   Clear columns H:I of data
    Range("H2:I" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
   
    '   Load the input array
    Dim ArrIn(1 To 3)
    Dim i As Long, j As Long, LRow As Long, TotRows As Long
    j = 1
    For i = 1 To 3
        LRow = Columns(j).Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row
        ArrIn(i) = Cells(2, j).Resize(LRow - 1, 2)
        TotRows = TotRows + UBound(ArrIn(i), 1)
        j = j + 2
    Next i
   
    '   Load the output array
    Dim r As Long, rw As Long, col As Long, arr
    ReDim ArrOut(1 To TotRows, 1 To 2)
    r = 1
    For i = 1 To 3
        arr = ArrIn(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                ArrOut(r, col) = arr(rw, col)
            Next col
            r = r + 1
        Next rw
    Next i
   
    '   Return the output array to the sheet & remove the duplicates
    Range("H2").Resize(UBound(ArrOut, 1), 2).Value = ArrOut
    Range("H:I").RemoveDuplicates Columns:=2, Header:=xlYes
    Application.ScreenUpdating = True
   
End Sub

Let me be precise, data is available in columns B, C & K, L & T, U with heading as account number and name respectively. I need a result in columns AC and AD. Can you make changes in above codes? And you got it correct that row 1 being a header

kevin9999 · Sep 27, 2022

Thank you for the clarification. Just a few tweaks required:

VBA Code:

Option Explicit
Sub Siddhu11011_V2()
    Application.ScreenUpdating = False
    
    '   Clear columns AC:AD of data
    Range("AC2:AD" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
    
    '   Load the input array
    Dim ArrIn(1 To 3)
    Dim i As Long, j As Long, LRow As Long, TotRows As Long
    j = 2
    For i = 1 To 3
        LRow = Columns(j).Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row
        ArrIn(i) = Cells(2, j).Resize(LRow - 1, 2)
        TotRows = TotRows + UBound(ArrIn(i), 1)
        j = j + 9
    Next i
    
    '   Load the output array
    Dim r As Long, rw As Long, col As Long, arr
    ReDim ArrOut(1 To TotRows, 1 To 2)
    r = 1
    For i = 1 To 3
        arr = ArrIn(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                ArrOut(r, col) = arr(rw, col)
            Next col
        r = r + 1
        Next rw
    Next i
    
    '   Return the output array to the sheet & remove the duplicates
    Range("AC2").Resize(UBound(ArrOut, 1), 2).Value = ArrOut
    Range("AC:AD").RemoveDuplicates Columns:=2, Header:=xlYes
    Application.ScreenUpdating = True

End Sub

mohadin · Sep 27, 2022

Hi
What about

VBA Code:

Sub test2()
    Dim a
    Dim ar As Object
    Dim i&, ii&
    ReDim a(1 To 3)
    With Sheets("sheet3")
        .[AC:AD].ClearContents
        For Each ar In .Cells.SpecialCells(2, 23).Areas
            i = i + 1: a(i) = ar.Offset(1).Value
        Next
    End With
    For i = 1 To UBound(a)
        Cells(2 + ii, 29).Resize(UBound(a(i)) - 1, 2) = a(i)
        ii = UBound(a(i)) - 1 + ii
    Next
End Sub

Siddhu11011 · Sep 27, 2022

kevin9999 said:

Thank you for the clarification. Just a few tweaks required:

VBA Code:

Option Explicit
Sub Siddhu11011_V2()
    Application.ScreenUpdating = False
   
    '   Clear columns AC:AD of data
    Range("AC2:AD" & Cells.Find("*", , xlFormulas, , 1, 2).Row).ClearContents
   
    '   Load the input array
    Dim ArrIn(1 To 3)
    Dim i As Long, j As Long, LRow As Long, TotRows As Long
    j = 2
    For i = 1 To 3
        LRow = Columns(j).Resize(, 2).Find("*", , xlFormulas, , 1, 2).Row
        ArrIn(i) = Cells(2, j).Resize(LRow - 1, 2)
        TotRows = TotRows + UBound(ArrIn(i), 1)
        j = j + 9
    Next i
   
    '   Load the output array
    Dim r As Long, rw As Long, col As Long, arr
    ReDim ArrOut(1 To TotRows, 1 To 2)
    r = 1
    For i = 1 To 3
        arr = ArrIn(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                ArrOut(r, col) = arr(rw, col)
            Next col
        r = r + 1
        Next rw
    Next i
   
    '   Return the output array to the sheet & remove the duplicates
    Range("AC2").Resize(UBound(ArrOut, 1), 2).Value = ArrOut
    Range("AC:AD").RemoveDuplicates Columns:=2, Header:=xlYes
    Application.ScreenUpdating = True

End Sub

I`m getting below result: I think issue lies in the cells B2, K2 AND T2. Array formula (Filter function) is applied in all of these 3 cells. That`s why it captured only row 2 data. Data from the remaining rows are missing. Can you modify above code?

1254	Shahid
12458	Taylor
cadda3333	Dinesh

kevin9999 · Sep 27, 2022

It would have been useful to know that at the beginning

Can you provide a copy of your actual sheet using the XL2BB add in so we reduce the need for all the back and forth?

mohadin · Sep 27, 2022

Revised

VBA Code:

Sub test2()
    Dim a
    Dim ar As Object
    Dim i&, ii&
    ReDim a(1 To 3)
    With Sheets("sheet3")
        .[AC:AD].ClearContents
        For Each ar In .Cells.SpecialCells(2, 23).Areas
        .Range("AC1") = ar(1, 1).Value: [AD1] = ar(1, 2)
            i = i + 1: a(i) = ar.Offset(1).Value
        Next
    For i = 1 To UBound(a)
        .Cells(2 + ii, 29).Resize(UBound(a(i)) - 1, 2) = a(i)
        ii = UBound(a(i)) - 1 + ii
    Next
    .[AC:AD].RemoveDuplicates Columns:=2, Header:=xlYes
     End With
End Sub

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

Siddhu11011

Board Regular

Excel Facts

OaklandJim

Well-known Member

kevin9999

Well-known Member

Siddhu11011

Board Regular

Siddhu11011

Board Regular

kevin9999

Well-known Member

mohadin

Well-known Member

Siddhu11011

Board Regular

kevin9999

Well-known Member

mohadin

Well-known Member

Similar threads

Forum statistics

Share this page

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

Board Regular

Excel Facts

Well-known Member

Well-known Member

Board Regular

Board Regular

Well-known Member

Well-known Member

Board Regular

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock