I have a macro that can pull unique data from "Column A" but I also want the corresponding values from other columns of those unique values from Column A and I want them on a different spreadsheet. I tried using Worksheet Vlookup function in the code but it takes way too long for the dataset of over 70,000 rows and 42 columns. The code -

Sub UniqueProductDetails()

Dim ws1 as worksheet
Dim ws2 as worksheet

Ws1 = Worksheets(“Source”)
Ws2 = Worksheets(“Destination”)

SRow = Ws1.range(“A” & Rows.count).End(xlUp).Row 

Ws1.Range(“A1:A” & SRow).AdvancedFilter Action:=xlFilterCopy, Unique=True, copytorange:=ws2.range(“A1”) 

'This code provides unique column A values in the Destination sheet

End Sub()  

Data and Output is in this format

CodePudding user response：

Create Unique Column Data Worksheets

• In a nutshell, it will split the data by ProductID (column 1) into as many worksheets as there are (unique) ProductIDs.

Option Explicit

Sub CreateProductWorksheets()

    ' Define constants.

    ' s - Source (read from)
    Const sName As String = "Source"
    Const sCriteriaColumn As Long = 1
    Const sFirstCellAddress As String = "A1"
    ' d - Destination (write to)
    Const dFirstCellAddress As String = "A1"
    
    ' Reference the workbook ('wb').
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source objects.
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    ' Clear previous filters.
    If sws.FilterMode Then sws.ShowAllData
    ' Reference the source (table) range ('srg').
    Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
    ' Reference the source header row range ('shrrg')
    ' used to copy the column widths.
    Dim shrrg As Range: Set shrrg = srg.Rows(1)
    ' Reference the source criteria (one-column) range ('scrg').
    Dim scrg As Range: Set scrg = srg.Columns(sCriteriaColumn)
    
    ' Write the values from the source criteria DATA range,
    ' the source criteria range without the header, to an array ('cData').
    
    Dim cData As Variant
    cData = scrg.Resize(scrg.Rows.Count - 1).Offset(1).Value
    
    ' Write the unique criteria values to a dictionary ('dict').
    
    ' Define a dictionary object ('dict') whose keys will hold
    ' the string representation of the unique values of the criteria array.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'A = a'
    
    Dim sKey As Variant ' Current Criteria Value (String)
    Dim r As Long ' Current Row in Criteria Array
        
    For r = 1 To UBound(cData, 1)
        If Not IsError(cData(r, 1)) Then ' exclude error values
            ' Convert to string because 1.) 'AutoFilter' likes strings
            ' and 2.) if the worksheet names are numbers ('1, 2, 3...'),
            ' they might get mistaken for worksheet indexes below,
            ' in the continuation of the code ('Set dws = wb.Worksheets(sKey)').
            sKey = CStr(cData(r, 1))
            If Len(sKey) > 0 Then ' exclude blanks
                dict(sKey) = Empty
            End If
        End If
    Next r
    
    ' Copy data.
    ' Loop through the keys of the dictionary and on each iteration,
    ' filter the source worksheet by the key and copy the filtered
    ' range to a newly created worksheet.
    
    Application.ScreenUpdating = False
    
    Dim dws As Worksheet ' Current Destination Worksheet
    Dim dfCell As Range ' Current Destination First Cell
    
    For Each sKey In dict.Keys
        
        ' Attempt to reference the destination worksheet...
        On Error Resume Next
            Set dws = wb.Worksheets(sKey)
        On Error GoTo 0
        
        ' ... and delete it if it exists.
        If Not dws Is Nothing Then ' destination worksheet exists
            Application.DisplayAlerts = False ' delete without confirmation
                dws.Delete
            Application.DisplayAlerts = True
        'Else ' destination worksheet doesn't exist; do nothing
        End If
        
        ' Add and reference a new worksheet, the destination worksheet...
        Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        dws.Name = sKey ' ... and rename it.
        
        ' Reference the destination first cell.
        Set dfCell = dws.Range(dFirstCellAddress)
        
        ' Copy the column widths using just the source header row range.
        shrrg.Copy
        dfCell.PasteSpecial Paste:=xlPasteColumnWidths
        dfCell.Select ' so the selection is not the destination header row
        
        ' Filter the source range.
        srg.AutoFilter sCriteriaColumn, sKey
        
        ' Copy the filtered range to the destination worksheet.
        srg.SpecialCells(xlCellTypeVisible).Copy dfCell
        
        ' Clear the current filter.
        sws.ShowAllData
        
        ' Reset the destination worksheet variable for the next
        ' attempt to reference the destination worksheet to work correctly.
        Set dws = Nothing
        
    Next sKey
    
    ' Remove the filter.
    sws.AutoFilterMode = False
    
    ' Select the source worksheet.
    sws.Select
    
    ' Save the workbook.
    'wb.Save
        
    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Product worksheets created.", vbInformation

End Sub

CodePudding user response：

You may achieve this with a formula as well:

=LET(newColumns,INDEX(tblData,SEQUENCE(ROWS(tblData)),{1,2,3,7,4}),
     UNIQUE(newColumns))

newColumns returns the table with the new column order

Then you can return the unique values.

Together with VSTACK you could add the header columns as well to the output (I don't have that version yet)

Using the formulas with VBA:

ub writeUniqueReorderedList()

Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Destination")

With ws2
    'ColumnHeaders
    .Range("A1").Formula2 = "=INDEX(tblData[#Headers],1,{1,2,3,7,4})"
    .Range("A2").Formula2 = "=LET(newColumns,INDEX(tblData,SEQUENCE(ROWS(tblData)),{1,2,3,7,4}), " & _
            "UNIQUE(newColumns))"
    
    With .Range("A1").CurrentRegion
        .Value = .Value
    End With
End With
    
End Sub