VBA Generate sheets with unique values

[winstonhuxle]

Hello,

I am looking for a code, that will help me to sort some data by country. I have huge file with different countries and need to make sheet for every unique country, involved in this file (let's say that these countries are in column C). I know how to write code manually for every country, but the list of countries varies by time. Could you help me?

Thank you for your time

[patel]

Can you attach a small sample file with data and desired result ?

[snb]

sub M_snb()
  sn=sheets(1).usedrange.columns(3)

  with createobject("scripting.dictionary")
    for j=1 to ubound(sn)
      if sn(j,1)<>"" then x0=.item(sn(j,1))
    next

    for each it in .keys
      sheets.add.name=it
    next
  end with
End Sub

[nilem]

or

Sub ertert()
Dim s$, v: Application.ScreenUpdating = False: s = "~"
For Each v In Range("C1", Cells(Rows.Count, 3).End(xlUp)).Value
    If v <> vbNullString Then
        If InStr(s, "~" & v & "~") = 0 Then
            If Not Evaluate("ISREF('" & v & "'!A1)") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = v
            s = s & v & "~"
        End If
    End If
Next: Application.ScreenUpdating = True
End Sub

[snb]

@Nilem

after:=Sheets(Sheets.Count)

is redundant, because that's the default.

[winstonhuxle]

Hello guys, thanks snb, it works perfect but it just creates a tabs with every unique country. The next step i need to do is to copy row with specific country to a tab with the name of this country. I usualy work with this code but I guess it wont help me now

Dim rngA As Range
    Dim cellA As Range
     
    Set rngA = Range("C1", Range("C65536").End(xlUp))
    For Each cellA In rngA
        If cellA.Value = "Australia" Then
            cellA.EntireRow.Copy
            Workbooks("destination.xls").Activate
            Worksheets("Australia").Activate
            Sheets("Australia").Range("A65536").End(xlUp).Offset(1, 0).Select
            ActiveSheet.Paste
        End If
Next cellA

[snb]

Sub M_snb() 
    sn=sheets(1).usedrange.columns(3) 
     
    With createobject("scripting.dictionary") 
        For j=1 To UBound(sn) 
            If sn(j,1)<>"" Then x0=.item(sn(j,1)) 
        Next 
         
        For Each it In .keys 
            sheets.add.name=it 
        Next 
    End With

    For j=1 to ubound(sn)
      sheets(sn(j,3)).cells(rows.count,1).end(xlup).offset(1).entirerow=sheets(1).rows(j).value
    next
End Sub

[winstonhuxle]

It appears error on the row sheets(sn.....(j).value Run time error 9 Subscript out of range. Could you help?

[snb]

Please analyse the code yourself. Try to solve 'issues' before posting. It's the only way to larn to use VBA.

For j=1 To UBound(sn)
sheets(sn(j,1)).cells(rows.count,1).end(xlup).offset(1).entirerow=sheets(1).rows(j).valu e
Next

[nilem]

@snb Hi Snb, glad to see you here too
of Help on VBA "If Before and After are both omitted, the new sheet is inserted before the active sheet." only
thanks

@Winstonhuxle
maybe so

Sub ertert()
Dim s$, v As Range: Application.ScreenUpdating = False: s = "~"
For Each v In Range("C1", Cells(Rows.Count, 3).End(xlUp)).Cells
    If v <> vbNullString Then
        If InStr(s, "~" & v & "~") = 0 Then
            If Not Evaluate("ISREF('" & v & "'!A1)") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = v
            s = s & v & "~"
            Sheets(CStr(v)).Rows(1).Value = v.EntireRow.Value
        End If
    End If
Next: Application.ScreenUpdating = True
End Sub

[winstonhuxle]

Thank you snb. I will analyze it, however this macro is still a bit complicated for me. Thank you for your help I appreciated it.

[winstonhuxle]

However I modified this macro as you wrote. Error does not occur anymore but it does not copy rows. I really don't know where the problem is.

[nilem]

Winstonhuxle, you are ignoring my messages?
My code is causing the error, too?
Could you make an example of your file in which the error occurs

[winstonhuxle]

Hello nilem, sorry i did not notice your reply. Your macro creates sheets and copy only the first row with certain condition. I usually have more rows related to one country (ergo condition). Any idea?

[mancubus]

Hello guys, thanks snb, it works perfect but it just creates a tabs with every unique country. The next step i need to do is to copy row with specific country to a tab with the name of this country. I usualy work with this code but I guess it wont help me now

do you have 1 row of data for each country?

[mancubus]

imho, if the table has a header row, that must also be taken into account. if a country name's length is more than 31 characters the code will throw an error. a tab name cannot be longer tan 31 chars. this must also be handled in the code.

[SamT]

31 character Sheet Name handled. Original error duplicated.

Sub M_snb()
    sn = Sheets(1).UsedRange.Columns(3)
     
    With CreateObject("scripting.dictionary")
        For j = 1 To UBound(sn)
            If sn(j, 1) <> "" Then x0 = .Item(sn(j, 1))
        Next
         
        For Each it In .keys
            Sheets.Add.Name = Left(it, 31)
        Next
    End With
     
    For j = 1 To UBound(sn)
        Sheets(sn(Left(j, 7), 31)).Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow = Sheets(1).Rows(j).Value
    Next
End Sub

PS: Header row is j=1

[mancubus]

Sub M_snb_Revised()


    Application.ScreenUpdating = False
    
    Dim HeaderRow As Boolean
    HeaderRow = True
    
    With Sheets(1).UsedRange
        If HeaderRow Then 'row 1 is header row
            sn = .Columns(3).Offset(1).Resize(.Rows.Count - 1)
        Else 'no header row
            sn = .Columns(3)
        End If
    End With
    
    With CreateObject("Scripting.Dictionary")
        For j = 1 To UBound(sn)
            If sn(j, 1) <> "" Then x0 = .Item(sn(j, 1))
        Next
    
        For Each it In .keys
            Sheets(1).Cells(1).CurrentRegion.AutoFilter Field:=3, Criteria1:=it
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = Left(it, 31)
            Sheets(1).AutoFilter.Range.Copy Sheets(Left(it, 31)).Range("A1")
            Sheets(1).AutoFilterMode = False
        Next
    End With
    
    Application.ScreenUpdating = True
    
End Sub

[winstonhuxle]

Hi all, thank you very much. Code of mancubus finally works and it work perfectly I forget to mention header, but countries should not have more than 31 character (at least I dont know about any country like this). Thank you I really appreciate your help. Have a nice day
Just one correction of code
If sn(j, 1) <> "" Then x0 = .Item(sn(j, 1))
thanks

[mancubus]

i somehow cant manage to copy special chars such as < > vbLf in my office computer. and cant add attachments.

i corrected the code at home.



well.
google says The United Kingdom of Great Britain and Northern Ireland is 48 chars long...

in future, yo may need to separate your table depending on some other values which are longer than 31 chars. so prepare for war today.