Need help :-(

[bboy]

Hey,

I need help splitting a list like the below in to a new excel work book. So all players from room 1 are saved in to an excel called room1 and so on. All the feilds must be present.

<TABLE style="WIDTH: 206pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=273><COLGROUP><COL style="WIDTH: 48pt" width=64><COL style="WIDTH: 53pt; mso-width-source: userset; mso-width-alt: 2560" width=70><COL style="WIDTH: 38pt; mso-width-source: userset; mso-width-alt: 1828" width=50><COL style="WIDTH: 67pt; mso-width-source: userset; mso-width-alt: 3254" width=89><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; WIDTH: 48pt; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20 width=64>Nickname</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; WIDTH: 53pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" class=xl63 width=70>Username</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; WIDTH: 38pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" width=50>room</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; WIDTH: 67pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" width=89>Amount Won</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player1</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player1</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room1</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>1</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player2</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player2</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room1</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>1</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player3</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player3</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room1</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>1</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player3</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player3</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room2</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>2</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player4</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player4</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room2</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>2</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player5</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player5</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room2</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>2</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player6</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player6</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room3</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>3</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player7</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player7</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room3</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>3</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" height=20>Player8</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Player8</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2">Room3</TD><TD style="BORDER-BOTTOM: #e2e2e2; BORDER-LEFT: #e2e2e2; BACKGROUND-COLOR: transparent; BORDER-TOP: #e2e2e2; BORDER-RIGHT: #e2e2e2" align=right>3</TD></TR></TBODY></TABLE>

I kind of got one to work but i dont really know what i am doing and it splits the list so many times by each row.

So just to re cap. The heads of Nickname username Room and amount won must stay then the players split by room. Here is what i have all ready. Can any one help me?

Sub Test()
Dim Sh As Worksheet
Dim rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim ShNew As Worksheet
Dim FName As String
Application.ScreenUpdating = False
' *** Change Sheet name to suit ***
Set Sh = Worksheets("Sheet1")
Set rng = Sh.Range("A2:D" & Sh.Range("D65536").End(xlUp).Row)
On Error Resume Next
For Each c In rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set rng = Sh.Range("A1:I" & Sh.Range("A65536").End(xlUp).Row)
For Each Item In List
Set ShNew = Worksheets.Add
ShNew.Name = Item
rng.AutoFilter Field:=3, Criteria1:=Item
Sh.Cells.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A2:D2")
ShNew.Copy
ActiveSheet.Rows(1).Delete
FName = ThisWorkbook.Path & "\" & Item & ".csv"
ActiveWorkbook.SaveAs Filename:=FName
ActiveWorkbook.Close SaveChanges:=False
rng.AutoFilter
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub

 

[VoG]

Take a look at Excel Explosion http://www.datapigtechnologies.com/freeware.htm

 

[bboy]

Hey it's not some thing I can really down loadon to a work computer

 

[VoG]

OK then look here http://www.mrexcel.com/forum/showthread.php?t=396069 (scroll down).

 

[bboy]

Hey thanks for that.

Just got a small problem.

I took the below from your sheet but when i try and open the new sheets that were saved it gives me an error. Do you know how to get rid of it? Plus id like it to save these as a csv file.

Error

"The file you are trying to open, 'Room1.csv' is in a different format than specified by the file extenstion. Verify that the file is not corrupted and is from a trusted source before opening this file."

Macro im using

Sub Splitlists()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
Master = .Name
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To LastRow
If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Cells(iStart, iCol).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> Master Then
sh.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".Csv"
ActiveWorkbook.Close
End If
Next sh
Application.ScreenUpdating = True
End If
End Sub

Id like to keep this macro as it is just changing the extenstion if possible to it is openable with out error and is also able to open in excel 2003

 

[VoG]

Try

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".Csv", FileFormat:=xlCSV

 

[bboy]

Thats awesome thank you.

Is there any way to just save it with out asking to save changes. As i got 60+ save changes pop ups lol

 

[VoG]

Try

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".Csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False

 

[bboy]

You are frigging awesome!!!! Thanks so much. I think i owe you some beers!!!

 

[bboy]

Hey Just one more problem one this.

This file shows as it being saved as a CSV but the saved csv files are only extenstions and not actual CSV (comma delimited) (*.csv) if you know what i mean. Is there another way to save it as a proper csv. The below is what i have now.

Sub Splitlists()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
Master = .Name
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To LastRow
If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Cells(iStart, iCol).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> Master Then
sh.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".Csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
End If
Next sh
Application.ScreenUpdating = True
End If
End Sub