create sheets based on column and copy data without repeating

[leap out]

hello
I have data in sheet1 contains data from a1: f and names ae existed in column b so I want creating sheets based on column b and copy data each name without repeating

1 .xlsm
	A	B	C	D	E	F
1	date	customer name	client number	invoice no	debit	credit
2	01/01/2020	ali	asd1223	IN1000	150000	1000
3	02/01/2020	omar	asd1224	IN1001	580000
4	03/01/2020	mohammed	asd1225	IN1002	170000	7000
5	04/01/2020	mariam	asd1226	IN1003	600000	100
6	05/01/2020	sarah	asd1227	IN1004	453200	400
7	06/01/2020	mahmoud	asd1228	IN1005	150000	10000
8	07/01/2020	ali	asd1223	IN1000		50000
9	08/01/2020	omar	asd1224	IN1001	1000	580000
10	09/01/2020	mohammed	asd1225	IN1002		100000
11	10/01/2020	mariam	asd1226	IN1003		500000
12	11/01/2020	sarah	asd1227	IN1004		435000
13	12/01/2020	mahmoud	asd1228	IN1005		100000
14	13/01/2020	sarah	asd1227	IN1006	23000
15	14/01/2020	mahmoud	asd1228	IN1007	5000
16	15/01/2020	omar	asd1224	IN1001	1000
17	16/01/2020	khalid	asd12299	in10032	50000	5000
18	17/01/2020	khalid	asd12300	in10033		5000
sheet1

thanks in advance

 

[maabadi]

Try this:

Sub GetUniques()

Dim d As Object, c As Variant, i As Long, lr As Long, ws As Worksheet, lr2 As Long, WS2 As Worksheet
Set ws = Sheets("Sheet1")
Set d = CreateObject("Scripting.Dictionary")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
c = Range("B2:B" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
ws.Range("H2").Resize(d.Count) = Application.Transpose(d.keys)
lr2 = ws.Cells(Rows.Count, 8).End(xlUp).Row
For Each Cell In ws.Range("H2:H" & lr2)
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cell.Value
Next Cell

For Each Worksheet In Worksheets
Set WS2 = Sheets(Worksheet.Name)
If WS2.Name <> "Sheet1" Then
For j = 1 To 6
WS2.Cells(1, j).Value = ws.Cells(1, j).Value
For i = 2 To lr
If ws.Cells(i, 2).Value = WS2.Name Then
WS2.Cells(i, j).Value = ws.Cells(i, j).Value
End If
Next i
Next j
End If
For i = lr To 2 Step -1
If WS2.Range("A" & i).Value = "" Then
WS2.Range("A" & i).EntireRow.Delete
End If
Next i
Next Worksheet
ws.Range("H2:H" & lr2).ClearContents
End Sub

 

[leap out]

wow ! great work but there is still something needs fixing if I run the macro repeatedly it gives me error the aim of run continuously may be I add a new data in sheet1 then if the sheet is already created then should update data i mean add the new data to old data I have ever copied

 

[dmt32]

Hi,
try following & see if helps

Option Explicit
Sub FilterColumn()
    'dmt32 aug 2020
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant
    Dim SheetName As String
   
    On Error GoTo progend
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
   
'Column you are filtering
    FilterCol = "B"
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
   
    With wsData
        .Activate
'add password if needed
        .Unprotect Password:=""
       
        Set Datarng = .Range("A1").CurrentRegion
       
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A1"), Unique:=True
       
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
       
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            SheetName = CStr(Left(FilterRange.Text, 31))
'check for blank cell in range
            If SheetName <> "" Then
'add the FilterRange to criteria
'part matches
                'wsFilter.Range("B2").Value = FilterRange.Value
'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & SheetName & """"
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If

'size column widths to match master
'NB - slows code down a little
            Datarng.Rows(1).Copy
            wsNames.UsedRange.Rows(1).PasteSpecial xlPasteColumnWidths
'clear from memory
            Set wsNames = Nothing
'clear clipboard
            Application.CutCopyMode = False
        Next
        .Select
    End With
   
progend:
    If Not wsFilter Is Nothing Then wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
   
    If Err <> 0 Then MsgBox (Error(Err)), vbCritical, "Error"
       
End Sub

Code will, if it does not already exist, create sheet for each name in column B & copy all matching data to it - You can refresh data as often as required

Dave

 

[leap out]

@ Dmt32
brilliant ! despite of the huge code , but it works very well , this is what I look for .
many thanks !

 

[dmt32]

@ Dmt32
brilliant ! despite of the huge code , but it works very well , this is what I look for .
many thanks !

It only looks "huge" because I include line comments & error handling

Glad it works ok for you

Dave