View Full Version : Solved: import and split a text file into worksheets by year
knifelong
08-21-2008, 07:53 AM
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
08-21-2008, 08:02 AM
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
08-21-2008, 08:26 AM
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
08-21-2008, 11:10 AM
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
08-26-2008, 03:25 AM
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
08-26-2008, 05:49 AM
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
08-26-2008, 08:07 AM
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.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.