Solved: import and split a text file into worksheets by year

[knifelong]

Hi

This is probably a fairly simple adaption to the procedure for importing a text file but I want to import a text file which has 5 comma deliminated columns into 5 columns in excel. This is the easy part but I am having difficulty with this part.....

The first column in the text file gives the year and each year is separated by a space. (you can see the format below) So basically I want to split each year into a separate worksheet. Any ideas? Thank you


here is an example of the format of the text file.


1985, 0 , 2495, 2068, 4563
1985, 1 , 6448, 5401, 11849
1985, 2 , 6430, 5634, 12064
1985, 3 , 6551, 5646, 12197

1986, 0 , 2732, 2476, 5208
1986, 1 , 7275, 6320, 13595
1986, 2 , 7348, 6138, 13486
1986, 3 , 7214, 6264, 13478

1987, 0 , 3180, 2762, 5942
1987, 1 , 8297, 7488, 15785
1987, 2 , 8395, 7275, 15670
1987, 3 , 8298, 7010, 15308

[marshybid]

Hi knifelong,

Code below provided to me by xld, worked well for me;


Sub AddSheets()
Dim LastRow As Long
Dim cell As Range
Dim sh As Worksheet

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("A1").Resize(LastRow)

.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End With

On Error Resume Next
For Each cell In .Range("A2").Resize(LastRow - 1).SpecialCells(xlCellTypeVisible)

.Parent.Worksheets.Add(after:=.Parent.Worksheets(.Parent.Worksheets.Count)) .Name = cell.Value
Next cell

.Activate
.ShowAllData
End With
End Sub


Hope it helps

Marshybid :hi:

[knifelong]

Hi thanks for the code marshybid.
The procedure will create the number of worksheets based on the year if the full file has already been imported into the active sheet but does not populate any data into any of the worksheets.

hmm..??

[darthobra]

Hi knifelong,

Try this...


Sub AddSheets()
Dim LastRow As Long
Dim cell As Range
Dim srcSh As Worksheet, sh As Worksheet
Dim r As Integer, destR As Integer
Dim curYear As String
Set srcSh = ActiveSheet
With srcSh

Columns("A:E").Select 'Change for actual columns
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A:A") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
.SetRange Range("A:E")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Range("A1").Select
End With
r = 1 'Assumes no headers

While srcSh.Cells(r, 1) <> ""
curYear = srcSh.Cells(r, 1)
If IsWorksheet(curYear) Then
destR = GetLastRow(srcSh.Cells(r, 1).Value)
Sheets(curYear).Cells(destR, 1) = srcSh.Cells(r, 1)
Sheets(curYear).Cells(destR, 2) = srcSh.Cells(r, 2)
Sheets(curYear).Cells(destR, 3) = srcSh.Cells(r, 3)
Sheets(curYear).Cells(destR, 4) = srcSh.Cells(r, 4)
'.etc
Else
srcSh.Parent.Worksheets.Add(after:=srcSh.Parent.Worksheets(srcSh.Parent.Wor ksheets.Count)).Name = srcSh.Cells(r, 1).Value
destR = GetLastRow(srcSh.Cells(r, 1).Value)
Sheets(curYear).Cells(destR, 1) = srcSh.Cells(r, 1)
Sheets(curYear).Cells(destR, 2) = srcSh.Cells(r, 2)
Sheets(curYear).Cells(destR, 3) = srcSh.Cells(r, 3)
Sheets(curYear).Cells(destR, 4) = srcSh.Cells(r, 4)
'.etc
End If
r = r + 1
Wend

End Sub
Function IsWorksheet(strSH As String) As Boolean

Dim sh As Worksheet
IsWorksheet = False
For Each sh In Worksheets
If sh.Name = strSH Then
IsWorksheet = True
Exit For
End If
Next

End Function
Function GetLastRow(strSH As String) As Integer
Dim r As Integer
r = 1
While Sheets(strSH).Cells(r, 1) <> ""
r = r + 1

Wend
GetLastRow = r
End Function



It works for me...

Darth

[knifelong]

Thanks for the post darthobra but I can't seem to get this code to work either.

I'm getting an "Object does not support this property or method" and
the debugger highlights this part as the error

" ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear "

I'm using Excel 2003. I'm trying to work out what the problem could be but I am new to VBA.

Regards

[TomSchreiner]

Another approach.
Code needs to be shored up...

Sub Example()
Dim Line, LineItems, Dest

On Error Resume Next
Open Application.GetOpenFilename For Input As #1
Do Until EOF(1)
Line Input #1, Line
LineItems = Split(Line, ",")
If UBound(LineItems) = 4 Then
Set Dest = Sheets(LineItems(0))
If Err.Number <> 0 Then Set Dest = Worksheets.Add(, Sheets(Sheets.Count))
Dest.Name = LineItems(0)
Dest.Cells(Dest.Cells(Dest.Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(, 5) = LineItems
End If
Err.Clear
Loop
Close

End Sub

[knifelong]

This works like a charm. Thanks Tom.
A lovely piece of code and so concise. I will be analysing this to learn from it. I will make sure to quote you when I use it. Many thanks again.