How to copy all the unique values to another excel sheet using macro?

[Rampage598]

pincode	vendor	rating	pending cases
1	xyz	2	0
2	xyz	2	41
3	xyz	2	45
1	xyz	1	4
2	xyz	3	17
4	xyz	2	0
5	xyz	2	45
6	xyz	3	17

This is my excel data i want to copy all the unique data of pincode to another excel sheet..
For eg. here there are pincode "1" which has 2count then all the data of pincode 1 will get copy into the another sheet with the name of pincode "1.xlsx" will create the file then it will copy all the data for 1 with headers into that created excel sheet..

How to do this in macro? i dont have any idea

 

[Georgiboy]

Maybe:

Sub test()
    Dim rng As Range, var As Variant
    Dim unq As Variant, x As Long
    Dim wb As Workbook, ws As Worksheet
    
    Set rng = Range("A1").CurrentRegion
    unq = Application.Sort(Application.Unique(rng.Offset(1).Resize(rng.Rows.Count - 1, 1)))
    
    rng.AutoFilter
    For x = 1 To UBound(unq)
        rng.AutoFilter 1, unq(x, 1)
        Set wb = Workbooks.Add
        Set ws = wb.Sheets(1)
        rng.SpecialCells(xlCellTypeVisible).Copy
        ws.Range("A1").PasteSpecial (xlValues)
        Application.CutCopyMode = False
        ws.Cells.EntireColumn.AutoFit
        ws.Rows(1).Font.Bold = True
        wb.SaveAs ThisWorkbook.Path & "\" & x & ".xlsx"
        wb.Close False
    Next x
    rng.AutoFilter
End Sub

 

[Rampage598]

Maybe:

Sub test()
    Dim rng As Range, var As Variant
    Dim unq As Variant, x As Long
    Dim wb As Workbook, ws As Worksheet
   
    Set rng = Range("A1").CurrentRegion
    unq = Application.Sort(Application.Unique(rng.Offset(1).Resize(rng.Rows.Count - 1, 1)))
   
    rng.AutoFilter
    For x = 1 To UBound(unq)
        rng.AutoFilter 1, unq(x, 1)
        Set wb = Workbooks.Add
        Set ws = wb.Sheets(1)
        rng.SpecialCells(xlCellTypeVisible).Copy
        ws.Range("A1").PasteSpecial (xlValues)
        Application.CutCopyMode = False
        ws.Cells.EntireColumn.AutoFit
        ws.Rows(1).Font.Bold = True
        wb.SaveAs ThisWorkbook.Path & "\" & x & ".xlsx"
        wb.Close False
    Next x
    rng.AutoFilter
End Sub

its working but i want to save as the pincode name.... if i have pincode "4560003" then it will save as this name

 

[Georgiboy]

Change this:

wb.SaveAs ThisWorkbook.Path & "\" & x & ".xlsx"

To:

wb.SaveAs ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx"

 

[Rampage598]

Change this:

wb.SaveAs ThisWorkbook.Path & "\" & x & ".xlsx"

To:

wb.SaveAs ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx"

Thanks, you are great

 

[Rampage598]

Change this:

wb.SaveAs ThisWorkbook.Path & "\" & x & ".xlsx"

To:

wb.SaveAs ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx"

Hey, can you give me the code for this data?

name	score	service	vendor
1​	asda	asd	Samsung
2​	asda	asd	Samsung
3​	asda	asd	Samsung
4​	asda	asd	Apple
5​	asda	asd	Apple
6​	asda	asd	Apple
7​	asda	asd	Nokia
8​	asda	asd	Nokia
9​	asda	asd	Nokia
10​	asda	asd	Nokia
11​	asda	asd	Vivo
12​	asda	asd	Vivo
13​	asda	asd	Vivo
14​	asda	asd	Oppo
15​	asda	asd	Vivo
16​	asda	asd	Vivo
17​	asda	asd	Nokia
18​	asda	asd	Oppo

Now i want to create the files according to the vendor column.... vendor column unique data need to transfer into the to separate excel sheet

 

[Georgiboy]

Maybe:

Sub test()
    Dim rng As Range, var As Variant
    Dim unq As Variant, x As Long
    Dim wb As Workbook, ws As Worksheet
    
    Set rng = Range("A1").CurrentRegion
    unq = Application.Sort(Application.Unique(rng.Offset(1, 3).Resize(rng.Rows.Count - 1, 1)))
    
    rng.AutoFilter
    For x = 1 To UBound(unq)
        rng.AutoFilter 4, unq(x, 1)
        Set wb = Workbooks.Add
        Set ws = wb.Sheets(1)
        rng.SpecialCells(xlCellTypeVisible).Copy
        ws.Range("A1").PasteSpecial (xlValues)
        Application.CutCopyMode = False
        ws.Cells.EntireColumn.AutoFit
        ws.Rows(1).Font.Bold = True
        wb.SaveAs ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx"
        wb.Close False
    Next x
    rng.AutoFilter
End Sub