VBA Generate sheets with unique values

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

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

Code:

---

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

---

or

Code:

---

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

---

@Nilem

after:=Sheets(Sheets.Count)

is redundant, because that's the default.

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

Code:

---

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

---

Code:

---

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

---

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

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

@snb Hi Snb, glad to see you here too :hi:
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

Code:

---

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

---

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.

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.

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

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?

Quote:

---

Originally Posted by 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

---

do you have 1 row of data for each country?

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.

31 character Sheet Name handled. Original error duplicated. :devil2:

Code:

---

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

Code:

---

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

---

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

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... :D

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. :)

[QUOTE=mancubus;] google says The United Kingdom of Great Britain and Northern Ireland is 48 chars long... :D

I've never been one for formal titles, so I just call them "Great Britain" and "Northern Ireland", as I suspect most people would do.

Quote:

---

so prepare for war today.

---

Feathers at 15 paces, at dawn tomorrow.
PS: bring plenty of beer it could be a long long day

Quote:

---

Originally Posted by mancubus

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

---

I don't normally refer to countries with their formal regalia, just "Great Britain" & 'Northern Ireland". As I suspect most people would do also.

Quote:

---

so prepare for war today.

---

Quote:

---

:)

---

Righto, Crow feathers at 15 paces, at dawn tomorrow.

PS: Bring plenty of beer, it could be a long day.

Well, countries in our company are seperated, I hope it won't change :D ... Btw why the code can't take value longer than 31 characters?

The code can handle, I think, 255 characters. The Sheet Tab names can only take 31.

That is why in my example the sheets are named "Left(strCountryName, 31)".