VBA to Copy Unique Values to New Sheet

[srj1359]

Hello!

I've got a "Quote Summary" sheet that I need to copy over data to a "Title List" sheet. How can I create a VBA that will copy each group of customers to the title sheet. Screenshot is attached. For example, I want just Customer A on the title list sheet, then just Customer B on a separate title list sheet. Any assistance you can provide is greatly appreciated.

Thank you!

 

[JLGWhiz]

You can have only one sheet in the workbook named "Title List". If you want each unique customer on a separate sheet then the sheet names would have to have a suffix like A, B, C or 1, 2, 3, etc.
The code can create and name the sheets. If you want to do it that way then this code would do that.

Sub UniqueCust()
Dim sh As Worksheet, nsh As Worksheet, lr As Long, c As Range, x As Long
Set sh = ActiveSheet
lr = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
sh.Range("A1", sh.Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , sh.Cells(lr + 2, 2), True
    For Each c In sh.Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Offset(1)
        If c <> "" Then
            Set nsh = Sheets.Add(After:=Sheets(Sheets.Count))
            x = x + 1
            nsh.Name = "Title List" & x
            sh.UsedRange.AutoFilter 1, c.Value
            sh.UsedRange.Copy nsh.Range("A1")
            sh.AutoFilterMode = False
            Set nsh = Nothing
        End If
    Next
sh.Cells(Rows.Count, 2).End(xlUp).CurrentRegion.ClearContents
End Sub

 

[srj1359]

Hi @JLGWhiz ,

Thank you for your response! Unfortunately, it's not doing anything for me. I'm not getting an error message, but it's also not generating anything like I would expect.

 

[JLGWhiz]

this is my test set up

Discussions.xlsm
	A	B	C
1	h	h	h
2	123	1	c1
3	123	2	c1
4	123	3	c1
5	234	4	c2
6	234	5	c2
7	234	6	c2
8	234	7	c2
9	345	8	c3
10	345	9	c3
Sheet1

The code produced three new sheets name Title List1, Title List2 and Title List3 with the appropriate data listed on each sheet. If your data is not in columns 1:3 then the code fails. If you run the code when a different sheet than the one with the three columns of data is active, the code fails.

Since sheet names were not provided, the sh variable was used to identify the sheet with the source data as the ActiveSheet. If any other sheet is active at run time, the the sh variable will be referring to that sheet instead of the one with the source data.

 

[srj1359]

@JLGWhiz Thank you -- I appreciate your help!

 

[JLGWhiz]

@JLGWhiz Thank you -- I appreciate your help!

You're welcome,
regards, JLG

 

[mohadin]

HI
Another approach
your data is not in columns 1:3

Sub test()
    Dim a As Variant, i, s, k, ky, itm, c
    Dim nsh As Worksheet
    a = Sheets("sheet1").Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 3)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> "" Then
                If Not .exists(a(i, 3)) Then
                    .Add a(i, 3), a(i, 1) & "," & a(i, 2) & "-"
                Else
                    .Item(a(i, 3)) = .Item(a(i, 3)) & a(i, 1) & "," & a(i, 2) & "-"
                End If: End If
        Next
        itm = .items:  ky = .keys
        c = 0
        For Each k In .keys
            Set nsh = Sheets.Add(After:=Sheets(Sheets.Count))
            nsh.Name = k
            s = Split(itm(c), "-")
            With Cells(1, 1)
            .Resize(UBound(s)) = Application.Transpose(s)
            .Resize(UBound(s)).TextToColumns , , , , 1, , , , 1
            .Offset(, 2).Resize(UBound(s)) = Application.Transpose(ky(c))
           End With
            c = c + 1
        Next
    End With
End Sub