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).value
Next

[nilem]

@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

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 nowdo 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. :devil2:


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

[Aussiebear]

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

[Aussiebear]

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.


so prepare for war today.
:)

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

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

[winstonhuxle]

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?

[SamT]

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