Hi!
i have a text document contains lot of informaiton with owner, department, group address and other things also
but i need only owner, department group
in group i have the information below
how do caputre everything department and group in coloum vise
Last edited by kamakshi; Dec 28th, 2011 at 07:05 PM.
Hi!
thanks
in excel
department column vise and group column vise
owner deparment1 department2 department 3 ....department 4...department 5 so on. group
robert @RXUJBRO @RXUJSCH @RXUJSCH XUJ
the text documnet have 255 pages
each page they have group
under the group they have like the below
or one line
need to capture Owner, department group
in column vise
Last edited by kamakshi; Dec 28th, 2011 at 07:05 PM.
Sub m()
Dim data() As String
Dim contents As String
Dim a As Integer
Dim owner As Boolean
owner = False
Open "c:/data.txt" For Input As 1
contents = Input(FileLen("c:/data.txt"), 1)
Close #1
contents = Replace(contents, vbCr, "{cr}")
contents = Replace(contents, vbLf, "{lf}")
contents = Replace(contents, "{cr}{lf}{cr}{lf}", "{cr}{lf}")
data = Split(contents, "{cr}{lf}")
For a = 0 To UBound(data)
'set flags
Select Case Left$(data(a), 6)
Case "OWNER:"
Debug.Print data(a)
owner = True
Case "DEPART"
If owner Then
Debug.Print data(a)
front = "DEPARTMENTS:"
End If
Case " GROUP"
If owner Then
Debug.Print data(a)
Else
'test only
'Debug.Print data(a) & " [X]"
End If
If owner Then front = " GROUP :"
Case " SURRO"
owner = False
front = ""
'test
'Debug.Print data(a) & " [X]"
Case "------", "CKT OS", " ACCTN", " DATAS", " FIREI", " SURRO", " MKS O"
'test only
'Debug.Print data(a) & " [X]"
Case Else
If owner Then
data(a) = front & Mid$(data(a), Len(front))
Debug.Print data(a)
End If
End Select
Next a
End Sub
Sub m()
Dim data() As String
Dim contents As String
Dim a, dep, grp As Integer
Dim owner As Boolean
owner = False
dep = 0
grp = 0
Open "c:/data.txt" For Input As 1
contents = Input(FileLen("c:/data.txt"), 1)
Close #1
contents = Replace(contents, vbCr, "{cr}")
contents = Replace(contents, vbLf, "{lf}")
contents = Replace(contents, "{cr}{lf}{cr}{lf}", "{cr}{lf}")
data = Split(contents, "{cr}{lf}")
For a = 0 To UBound(data)
'set flags
Select Case Left$(data(a), 6)
Case "OWNER:"
Debug.Print data(a)
owner = True
Case "DEPART"
If owner Then
dep = a
Debug.Print data(a)
front = "DEPARTMENTS:"
End If
Case " GROUP"
If owner Then
dep = 0
grp = a
Debug.Print data(a)
Else
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
End If
If owner Then front = " GROUP :"
Case " SURRO"
owner = False
front = ""
data(a) = "x"
'test
'Debug.Print data(a) & " [X]"
Case "------", "CKT OS", " ACCTN", " DATAS", " FIREI", " SURRO", " MKS O"
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
Case Else
If owner Then
'data(a) = front & Mid$(data(a), Len(front))
'Debug.Print data(a)
If dep > 0 Then
data(dep) = data(dep) & data(a)
data(a) = "x"
Debug.Print data(dep)
End If
If grp > 0 Then
data(grp) = data(grp) & data(a)
data(a) = "x"
Debug.Print data(grp)
End If
Else
data(a) = "x"
End If
End Select
Next a
For a = 0 To UBound(data)
Debug.Print data(a)
Next a
End Sub
bits now appear in the right places and empty lines are now marked for deletion
Sub m()
Dim data() As String
Dim contents As String
Dim a, dep, grp As Integer
Dim owner As Boolean
owner = False
dep = 0
grp = 0
Open "c:/data.txt" For Input As 1
contents = Input(FileLen("c:/data.txt"), 1)
Close #1
contents = Replace(contents, vbCr, "{cr}")
contents = Replace(contents, vbLf, "{lf}")
contents = Replace(contents, "{cr}{lf}{cr}{lf}", "{cr}{lf}")
data = Split(contents, "{cr}{lf}")
For a = 0 To UBound(data)
'set flags
Select Case Left$(data(a), 6)
Case "OWNER:"
Debug.Print data(a)
owner = True
Case "DEPART"
If owner Then
dep = a
Debug.Print data(a)
front = "DEPARTMENTS:"
End If
Case " GROUP"
If owner Then
dep = 0
grp = a
Debug.Print data(a)
Else
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
End If
If owner Then front = " GROUP :"
Case " SURRO"
owner = False
front = ""
'special empty flag when added will cause a record break
'for test purposes "{lf}{cr}" used instead of vblf & vbcr
data(a) = "{lf}{cr}"
'test
'Debug.Print data(a) & " [X]"
Case "------", "CKT OS", " ACCTN", " DATAS", " FIREI", " SURRO", " MKS O"
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
Case Else
If owner Then
'data(a) = front & Mid$(data(a), Len(front))
'Debug.Print data(a)
If dep > 0 Then
data(dep) = data(dep) & data(a)
data(a) = "x"
Debug.Print data(dep)
End If
If grp > 0 Then
data(grp) = data(grp) & data(a)
data(a) = "x"
Debug.Print data(grp)
End If
Else
data(a) = "x"
End If
End Select
Next a
For a = 0 To UBound(data)
Debug.Print data(a)
Next a
'just output non x lines
'data(0) will always bean owner so ...
output = data(0)
For a = 1 To UBound(data)
'concatenate the data with tab separator
'for test purposes "{tab}" used instead of vbtab
sep = "{tab}"
'ensure no empty cells
If data(a) = "{lf}{cr}" Then sep = ""
If Not (data(a) = "x") Then output = output & sep & data(a)
Next a
'each record will now conform to the shape you wanted
'but is not pretty yet
Debug.Print output
End Sub
but it is not right yet...
we still need to calculate the number of columns for the departments and the number of columns for the groups
then the data will need to be lined up to those headings
so for each record we need to count he entries under department and under group then pad out the records to suit.
so we must first make the department and group bits easy to count
Hi incidentals
thanks once again. still confusing pelase helpe me
departmens 6 yes i agree with that
but when it capture inot excel i have a code above. could yuo help me where do i caputre your code with my code.
thanks once again.
Sub m()
Const vbspace As String = " "
Dim data() As String
Dim contents As String
Dim a, dep, grp As Integer
Dim owner As Boolean
Dim owner_max, dep_max, grp_max As Integer
owner = False
dep = 0
grp = 0
Open "c:\test\data.txt" For Input As 1
contents = Input(FileLen("c:\test\data.txt"), 1)
Close #1
contents = Replace(contents, vbCr, "{cr}")
contents = Replace(contents, vbLf, "{lf}")
contents = Replace(contents, "{cr}{lf}{cr}{lf}", "{cr}{lf}")
data = Split(contents, "{cr}{lf}")
For a = 0 To UBound(data)
'set flags
Select Case Left$(data(a), 6)
Case "OWNER:"
Debug.Print data(a)
owner = True
Case "DEPART"
If owner Then
dep = a
Debug.Print data(a)
front = "DEPARTMENTS:"
End If
Case " GROUP"
If owner Then
dep = 0
grp = a
Debug.Print data(a)
Else
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
End If
If owner Then front = " GROUP :"
Case " SURRO"
owner = False
front = ""
'special empty flag when added will cause a record break
'for test purposes "{lf}{cr}" used instead of vblf & vbcr
data(a) = "{lf}{cr}"
'test
'Debug.Print data(a) & " [X]"
Case "------", "CKT OS", " ACCTN", " DATAS", " FIREI", " SURRO", " MKS O"
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
Case Else
If owner Then
'data(a) = front & Mid$(data(a), Len(front))
'Debug.Print data(a)
If dep > 0 Then
data(dep) = data(dep) & data(a)
data(a) = "x"
Debug.Print data(dep)
End If
If grp > 0 Then
data(grp) = data(grp) & data(a)
data(a) = "x"
Debug.Print data(grp)
End If
Else
data(a) = "x"
End If
End Select
Next a
For a = 0 To UBound(data)
Debug.Print data(a)
Next a
'just output non x lines
'data(0) will always bean owner so ...
output = data(0)
For a = 1 To UBound(data)
'concatenate the data with tab separator
'for test purposes "{tab}" used instead of vbtab
sep = "{tab}"
'ensure no empty cells
If data(a) = "{lf}{cr}" Then sep = ""
If Not (data(a) = "x") Then output = output & sep & data(a)
Next a
'each record will now conform to the shape you wanted
'but is not pretty yet
Debug.Print output
'lets try removing some of the excess space
'a bit exessive I know but what the hey
For a = 1 To 100
output = Replace(output, " ", " ")
Next a
'owners names may include comma
output = Replace(output, ",", "")
'group includes space before :
output = Replace(output, " :", ":")
'thats for sure only 1 space between things
Debug.Print output
owner_max = 0
dep_max = 0
grp_max = 0
'bring back data contents in this nicer format
data = Split(output, "{lf}{cr}")
'data(0) is now the data of the first owner
'walk the data to find max values
For a = 0 To UBound(data) - 1
field = Split(data(a), "{tab}")
'field(0) is the owner
'field(1) is the departments
'field(2) is the groups
'we can break the fields into individual entries
entry = Split(field(0), vbspace)
'entry(0) is the word owner:
'entry(1) to entry(ubound) is owner's name excluding commas
If UBound(entry) > owner_max Then owner_max = UBound(entry)
entry = Split(field(1), vbspace)
'entry(0) is the word Department:
'entry(1) to entry(ubound(entry)) are the actual values
'so ubound(entry)-1 is the number of values in departments
'if we keep max department count we can bulk up when required
If UBound(entry) > dep_max Then dep_max = UBound(entry)
entry = Split(field(2), vbspace)
'entry(0) is a leading space
'entry(1) is the word group:
'entry(2 to entry(ubound(entry)) are the actual values
'as above
If UBound(entry) - 1 > grp_max Then grp_max = UBound(entry) - 1
Next a
'now we have the column maximums
'owner = owner_max
'departments= dep_max
'group=grp_max
Header = ""
Header = "owner1"
For a = 2 To owner_max
Header = Header & vbTab & "owner" & a
Next a
For a = 1 To dep_max
Header = Header & vbTab & "dept" & a
Next a
For a = 1 To grp_max
Header = Header & vbTab & "group" & a
Next a
Header = Header & vbLf & vbCr
Debug.Print Header
'remove interim headings and human readable separators
output = Replace(output, "OWNER: ", "")
output = Replace(output, "{tab}DEPARTMENTS: ", vbTab)
output = Replace(output, "{tab} GROUP: ", vbTab)
'replace spaces with meaningfull separator
output = Replace(output, vbspace, vbTab)
'replace record separators with correct separators
output = Replace(output, "{lf}{cr}", vbLf & vbCr)
'attach header
output = Header & output
'write out final file
Open "c:\test\testoutput.xlt" For Output As #1
Print #1, output
Close #1
MsgBox "all done"
End Sub
all done - simply double click output file to enter data into excel - seems to work here
Hi incidentals
thanks a lot. it saves lot of time. if i have the same sample it wokrs fine. but i have a large file
when i run this macro it has error
Run-time error '62': Input past end of file.
contents = Input(FileLen("c:\test\data.txt"), 1)
there are a number of faults with the thing so far I have left the vblfvbcr ending that is ot requires on vbcr is needed... causes intermediate cells to appear in sheet I think ... was told to get to bed... by the boss.
and the other is padding the columns out where no data exists...
i was just about to multiply up the sample to do the padding thing
can you send a lump of the data for me to test against
you should not be able to read beyond the filelen(filename) as this is the size of the file!
its a long from -2,147,483,647 to 2,147,483,647 that should be way more than you need!
I think you have the wrong file name or path for the non sample!
here to talk
tah
Last edited by incidentals; Dec 27th, 2011 at 04:16 AM.
correctly record separated version with infile and outfile for file name handling
Code:
Sub m()
Const vbspace As String = " "
Dim data() As String
Dim contents As String
Dim a, dep, grp As Integer
Dim owner As Boolean
Dim owner_max, dep_max, grp_max As Integer
owner = False
dep = 0
grp = 0
'store input file in variable
' you could always ask or browse for this
infile = "c:\test\data.txt"
'store input file in variable
' you could always ask or browse for this
outfile = "c:\test\testoutput.xlt"
Open infile For Input As 1
contents = Input(FileLen(infile), 1)
Close #1
contents = Replace(contents, vbCr, "{cr}")
contents = Replace(contents, vbLf, "{lf}")
contents = Replace(contents, "{cr}{lf}{cr}{lf}", "{cr}{lf}")
data = Split(contents, "{cr}{lf}")
For a = 0 To UBound(data)
'set flags
Select Case Left$(data(a), 6)
Case "OWNER:"
Debug.Print data(a)
owner = True
Case "DEPART"
If owner Then
dep = a
Debug.Print data(a)
front = "DEPARTMENTS:"
End If
Case " GROUP"
If owner Then
dep = 0
grp = a
Debug.Print data(a)
Else
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
End If
If owner Then front = " GROUP :"
Case " SURRO"
owner = False
front = ""
'special empty flag when added will cause a record break
'for test purposes "{lf}{cr}" used instead of vblf & vbcr
data(a) = "{lf}{cr}"
'test
'Debug.Print data(a) & " [X]"
Case "------", "CKT OS", " ACCTN", " DATAS", " FIREI", " SURRO", " MKS O"
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
Case Else
If owner Then
'data(a) = front & Mid$(data(a), Len(front))
'Debug.Print data(a)
If dep > 0 Then
data(dep) = data(dep) & data(a)
data(a) = "x"
Debug.Print data(dep)
End If
If grp > 0 Then
data(grp) = data(grp) & data(a)
data(a) = "x"
Debug.Print data(grp)
End If
Else
data(a) = "x"
End If
End Select
Next a
For a = 0 To UBound(data)
Debug.Print data(a)
Next a
'just output non x lines
'data(0) will always bean owner so ...
Output = data(0)
For a = 1 To UBound(data)
'concatenate the data with tab separator
'for test purposes "{tab}" used instead of vbtab
sep = "{tab}"
'ensure no empty cells
If data(a) = "{lf}{cr}" Then sep = ""
If Not (data(a) = "x") Then Output = Output & sep & data(a)
Next a
'each record will now conform to the shape you wanted
'but is not pretty yet
Debug.Print Output
'lets try removing some of the excess space
'a bit exessive I know but what the hey
For a = 1 To 100
Output = Replace(Output, " ", " ")
Next a
'owners names may include comma
Output = Replace(Output, ",", "")
'group includes space before :
Output = Replace(Output, " :", ":")
'thats for sure only 1 space between things
Debug.Print Output
owner_max = 0
dep_max = 0
grp_max = 0
'bring back data contents in this nicer format
data = Split(Output, "{lf}{cr}")
'data(0) is now the data of the first owner
'walk the data to find max values
For a = 0 To UBound(data) - 1
field = Split(data(a), "{tab}")
'field(0) is the owner
'field(1) is the departments
'field(2) is the groups
'we can break the fields into individual entries
entry = Split(field(0), vbspace)
'entry(0) is the word owner:
'entry(1) to entry(ubound) is owner's name excluding commas
If UBound(entry) > owner_max Then owner_max = UBound(entry)
entry = Split(field(1), vbspace)
'entry(0) is the word Department:
'entry(1) to entry(ubound(entry)) are the actual values
'so ubound(entry)-1 is the number of values in departments
'if we keep max department count we can bulk up when required
If UBound(entry) > dep_max Then dep_max = UBound(entry)
entry = Split(field(2), vbspace)
'entry(0) is a leading space
'entry(1) is the word group:
'entry(2 to entry(ubound(entry)) are the actual values
'as above
If UBound(entry) - 1 > grp_max Then grp_max = UBound(entry) - 1
Next a
'now we have the column maximums
'owner = owner_max
'departments= dep_max
'group=grp_max
Header = ""
Header = "owner1"
For a = 2 To owner_max
Header = Header & vbTab & "owner" & a
Next a
For a = 1 To dep_max
Header = Header & vbTab & "dept" & a
Next a
For a = 1 To grp_max
Header = Header & vbTab & "group" & a
Next a
Header = Header & "{lf}{cr}"
Debug.Print Header
'remove interim headings and human readable separators
Output = Replace(Output, "OWNER: ", "")
Output = Replace(Output, "{tab}DEPARTMENTS: ", vbTab)
Output = Replace(Output, "{tab} GROUP: ", vbTab)
'replace spaces with meaningfull separator
Output = Replace(Output, vbspace, vbTab)
'attach header
Output = Header & Output
'replace record human separators with correct single separator
Output = Replace(Output, "{lf}{cr}", vbCr)
'write out final file
Open outfile For Output As #1
Print #1, Output
Close #1
MsgBox "all done"
End Sub
the second set of values are not identical in size and the stuff is padded to suit
lots of side effects removed
the next version will of course be half the size and much quicker
But what fun would that be
Code:
Sub m()
Const vbspace As String = " "
Dim data() As String
Dim contents As String
Dim a, dep, grp As Integer
Dim owner As Boolean
Dim owner_max, dep_max, grp_max As Integer
Dim length As Long
owner = False
dep = 0
grp = 0
'store input file in variable
' you could always ask or browse for this
infile = "c:\test\data.txt"
'store input file in variable
' you could always ask or browse for this
outfile = "c:\test\testoutput.xlt"
Open infile For Input As 1
contents = Input(FileLen(infile), 1)
Close #1
contents = Replace(contents, vbCr, "{cr}")
contents = Replace(contents, vbLf, "{lf}")
contents = Replace(contents, "{cr}{lf}{cr}{lf}", "{cr}{lf}")
data = Split(contents, "{cr}{lf}")
For a = 0 To UBound(data)
'set flags
Select Case Left$(data(a), 6)
Case "OWNER:"
'test only
Debug.Print data(a)
owner = True
dep = 0
grp = 0
'mark start and end of record
'side effect leading blank record
data(a) = "{lf}{cr}" & data(a)
Case "DEPART"
If owner Then
dep = a
'test only
Debug.Print data(a)
front = "DEPARTMENTS:"
End If
Case " GROUP"
If owner Then
dep = 0
grp = a
'test only
Debug.Print data(a)
Else
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
End If
If owner Then front = " GROUP :"
Case " SURRO"
owner = False
front = ""
'special empty flag when added will cause a record break
'for test purposes "{lf}{cr}" used instead of vblf & vbcr
data(a) = "{lf}{cr}"
'test
'Debug.Print data(a) & " [X]"
Case "------", "CKT OS", " ACCTN", " DATAS", " FIREI", " SURRO", " MKS O"
data(a) = "x"
'test only
'Debug.Print data(a) & " [X]"
Case Else
If owner Then
'data(a) = front & Mid$(data(a), Len(front))
'Debug.Print data(a)
If dep > 0 Then
data(dep) = data(dep) & data(a)
data(a) = "x"
'test only
Debug.Print data(dep)
End If
If grp > 0 Then
data(grp) = data(grp) & data(a)
data(a) = "x"
'test only
Debug.Print data(grp)
End If
Else
data(a) = "x"
End If
End Select
Next a
'for test only
For a = 0 To UBound(data)
Debug.Print data(a)
Next a
'just output non x lines
'building up the output string
'data(0) will always bean owner so ...
output = data(0)
For a = 1 To UBound(data)
'concatenate the data with tab separator
'for test purposes "{tab}" used instead of vbtab
sep = "{tab}"
'ensure no empty cells
If data(a) = "{lf}{cr}" Then sep = ""
If Not (data(a) = "x") Then output = output & sep & data(a)
Next a
'side effects the start of each new record begins "{tab}OWNER"
'and first record begind "[lf}{cr}"
'empty lines produce "{lf}{cr}{tab}{lf}{cr}"
'fix
output = Replace(output, "{tab}OWNER", "OWNER")
output = Mid$(output, 9)
output = Replace(output, "{lf}{cr}{tab}{lf}{cr}", "{lf}{cr}")
'each record will now conform to the shape you wanted
'but is not pretty yet
'test only
Debug.Print output
'lets try removing some of the excess space
'a bit exessive I know but what the hey
'the maximum size of an empty field is the number of times
'you need to do this and thats still a little excessive
For a = 1 To 100
length = Len(output)
output = Replace(output, " ", " ")
'this will stop the loop if no more double spaces ae found
If length = Len(output) Then
'test only
Debug.Print a - 1 & " double spaces removed"
Exit For
End If
Next a
'owners names may include comma
output = Replace(output, ",", "")
'group includes space before :
output = Replace(output, " :", ":")
'thats for sure only 1 space between things
'test only
Debug.Print output
owner_max = 0
dep_max = 0
grp_max = 0
'bring back data contents in this nicer format
data = Split(output, "{lf}{cr}")
'data(0) is now the data of the first owner
'walk the data to find max values
For a = 0 To UBound(data) - 1
field = Split(data(a), "{tab}")
'field(0) is the owner
'field(1) is the departments
'field(2) is the groups
'we can break the fields into individual entries
entry = Split(field(0), vbspace)
'entry(0) is the word owner:
'entry(1) to entry(ubound) is owner's name excluding commas
If UBound(entry) > owner_max Then owner_max = UBound(entry)
entry = Split(field(1), vbspace)
'entry(0) is the word Department:
'entry(1) to entry(ubound(entry)) are the actual values
'so ubound(entry)-1 is the number of values in departments
'if we keep max department count we can bulk up when required
If UBound(entry) > dep_max Then dep_max = UBound(entry)
entry = Split(field(2), vbspace)
'entry(0) is a leading space
'entry(1) is the word group:
'entry(2 to entry(ubound(entry)) are the actual values
'as above
If UBound(entry) - 1 > grp_max Then grp_max = UBound(entry) - 1
Next a
'now we have the column maximums
'owner = owner_max
'departments= dep_max
'group=grp_max
'lets pad out the records
'by adding [tab} for each missing field
'walk through the contents again
For a = 0 To UBound(data) - 1
field = Split(data(a), "{tab}")
'field(0) is the owner
'field(1) is the departments
'field(2) is the groups
'we can break the fields into individual entries
entry = Split(field(0), vbspace)
'entry(0) is the word owner:
'entry(1) to entry(ubound) is owner's name excluding commas
If UBound(entry) < owner_max Then
pad = Abs(owner_max - UBound(entry))
For p = 1 To pad
entry(UBound(entry)) = entry(UBound(entry)) & "{pad}"
Next p
End If
'rejoin entries to field
field(0) = Join(entry, vbspace)
entry = Split(field(1), vbspace)
'entry(0) is the word Department:
'entry(1) to entry(ubound(entry)) are the actual values
'so ubound(entry)-1 is the number of values in departments
'if we keep max department count we can bulk up when required
If UBound(entry) < dep_max Then
pad = Abs(UBound(entry) - dep_max)
For p = 1 To pad
entry(UBound(entry)) = entry(UBound(entry)) & "{pad}"
Next p
End If
'rejoin entries to field
field(1) = Join(entry, vbspace)
entry = Split(field(2), vbspace)
'entry(0) is a leading space
'entry(1) is the word group:
'entry(2 to entry(ubound(entry)) are the actual values
'as above
If UBound(entry) < grp_max Then
pad = Abs(UBound(entry) - grp_max)
For p = 1 To pad
entry(UBound(entry)) = entry(UBound(entry)) & "{pad}"
Next p
End If
'rejoin entries to field
field(2) = Join(entry, vbspace)
'rejoin fields to data
data(a) = Join(field, "{tab}")
'test only
Debug.Print "data(a) = " & data(a)
Next a
'rejoin data to output
output = Join(data, "{lf}{cr}")
'what about the header
Header = "owner1"
For a = 2 To owner_max
Header = Header & vbTab & "owner" & a
Next a
For a = 1 To dep_max
Header = Header & vbTab & "dept" & a
Next a
For a = 1 To grp_max
Header = Header & vbTab & "group" & a
Next a
'using human readable record separator
Header = Header & "{lf}{cr}"
'test only
Debug.Print Header
'clean up the output structure
'remove all the human bits from within records
'remove interim headings and human readable separators
output = Replace(output, "OWNER: ", "")
output = Replace(output, "{tab}DEPARTMENTS: ", vbTab)
output = Replace(output, "{tab} GROUP: ", vbTab)
'replace spaces and padding with meaningfull separator
output = Replace(output, vbspace, vbTab)
output = Replace(output, "{pad}", vbTab)
'attach header
output = Header & output
'replace human record separators with correct single separator
output = Replace(output, "{lf}{cr}", vbCr)
'write out final file
'test only
Debug.Print output
Open outfile For Output As #1
Print #1, output
Close #1
'test only or keep for notification
MsgBox "all done"
End Sub
hope it all makes sense
you can remove any debug printing parts once you are happy with the workings
Hi incendentals
thank yu very much for helping me out. but still i could get the same error.
from the text document directly inot sheet either column vise or row vise
the owner in the text document corresponding department and group everyhting from the text documnet into excel
owener department groups
thanks for your great help once again
I read the file in a line at a time and pushit directly on to a sheet
it could all be a little neater, but it worked his 55 kb test file in 3 secs
Code:
Global current As Long
Global owner As Long
Global departments As Long
Global group As Long
Global last As Long
Global void As Long
Global t1 As Variant
Sub parser()
Dim lines As Long
Dim testmode As Boolean
MsgBox "Currently this macro will only parses the file..." & vbCr & vbCr & "C:\test\data.txt" & vbCr & vbCr & "Please ensure this is you file", vbOKOnly, "Parse control"
lines = Val(InputBox("how many line to parse - leave blank to parse whole document", "Parser control"))
'display fixes
plines = lines
If lines = 0 Then plines = 100000
wees = "s"
If lines = 1 Then wees = ""
If vbCancel = MsgBox("you are about to parse" & vbLf & vbLf & plines & " Line" & wees & " of" & vbLf & vbLf & "C:\test\data.txt" & vbLf & vbLf & "OK to continue CANCEL to stop", vbOKCancel, "Parser control") Then Exit Sub
t1 = Now()
If lines = 0 Then
parse
Else
parse lines
End If
End Sub
Sub test()
DataFillTest
End Sub
Sub testprint()
DataFillTest True
End Sub
Sub testparser()
Dim lines As Long
Dim testmode As Boolean
lines = Val(InputBox("how many line to parse - leave blank to parse whole document", "Parser control"))
'display fixes
plines = lines
If lines = 0 Then plines = 100000
wees = "s"
If lines = 1 Then wees = ""
If vbCancel = MsgBox("you are about to parse" & vbLf & vbLf & plines & " Line" & wees & " of" & vbLf & vbLf & "C:\test\data.txt" & vbLf & vbLf & "OK to continue CANCEL to stop", vbOKCancel, "Parser control") Then Exit Sub
t1 = Now()
Stop
If lines = 0 Then
parse , True
Else
parse lines, True
End If
parse
End Sub
Sub DataFillTest(Optional ByVal test As Boolean = False)
initialise
MsgBox "part0 - new sheet made named today now() with basic headings"
If test Then Debug.Print current, owner, departments, group, last
insert "jim smith", current, owner, departments, group, last
If test Then Debug.Print current, owner, departments, group, last
insert "hello mum", current, departments, group, last, void
If test Then Debug.Print current, owner, departments, group, last
insert "goodbye daddy kins", current, group, last, void, void
If test Then Debug.Print current, owner, departments, group, last
MsgBox "part1 - additional columns no holes"
current = 3
If test Then Debug.Print current, owner, departments, group, last
insert "jim smith stanley", current, owner, departments, group, last
If test Then Debug.Print current, owner, departments, group, last
insert "hello mum bum", current, departments, group, last, void
If test Then Debug.Print current, owner, departments, group, last
insert "goodbye daddy", current, group, last, void, void
If test Then Debug.Print current, owner, departments, group, last
MsgBox "part2 - additional columns holes appear in previous row"
current = 4
If test Then Debug.Print current, owner, departments, group, last
insert "jim smith stanley", current, owner, departments, group, last
If test Then Debug.Print current, owner, departments, group, last
insert "hello mum", current, departments, group, last, void
MsgBox "part3 - no additional columns and a hole in departments"
If test Then Debug.Print current, owner, departments, group, last
insert "man", current, departments, group, last, void
MsgBox " part4 - no additions last department hole filled with 'man'"
If test Then Debug.Print current, owner, departments, group, last
insert "goodbye daddy oh", current, group, last, void, void
If test Then Debug.Print current, owner, departments, group, last
MsgBox "test complete"
End Sub
Sub initialise(Optional ByVal test As Boolean = False)
current = 2
owner = 1
departments = 2
group = 3
last = 4
void = 0
'create clean sheet
Sheets.Add before:=Sheets(1)
'the sheet will be called parsed - and todays date and time
ActiveSheet.Name = "Parsed - " & Format(Now(), "yyyymmdd - hh.mm.ss")
'layout headers
Range("a1:d1").Select
Selection(1).Value = "Owner_1"
Selection(2).Value = "Dept_1"
Selection(3).Value = "Group_1"
If test Then Selection(4).Value = "Last"
End Sub
Sub parse(Optional lines As Long = 100000, Optional test As Boolean = False)
Dim complete As String
'generate a new sheet and set header row and column values
initialise
'THOUGHTS **************************************************************************
'rather than have a large space avaliable
'i will goto the departments column and insert a column if need tho store a department
'and the same with groups
'i think that if i name the columns on the sheet it will deal with the calculations
'i could do the same when i get a new owner
'***********************************************************************************
'algorithm *************************************************************************
' put data into the next space of its type
'if the space is not empty move to next
'if space is in the first space of a different type
'insert and use a new column
'the different type space will have moved on
'if columns have names the namespace will automatically alter to cope
'so endcolumn will also have moved
'***********************************************************************************
'actions ***************************************************************************
'all actions should be subs
'prepair_sheet
'inset_new_owner name reflects special case
'insert_departments
'insert_groups
'***********************************************************************************
'finally ***************************************************************************
'abandoned named ranges as an approach as cannot get enough information
'the automatic nature is a maybe for later
'all column values are stored in globals
'you cannot add to a table with the parser!
'you can only make a new table and parse into it!
'the globals are reset each time you parse - columns would get mixed up
'the sub parse will work 100000 lines of input file by default
'the parser does not produce a test log
'using test in the call will cause the process to print out in the immediate window
'to do more or less you must include the number of lines in the call
'to parse 1000 lines type PARSE 100
'to parse 2000 lines with test output type parse 2000,true
'the parser is sequential
'the insert is recursive
'all insertions are done by 1 subroutine call insert(data,row,col1,col2,col3,col4)
'***********************************************************************************
complete = "This file has been completely parsed"
infile = "c:\test\data.txt"
'test only
If test And (lines = 100000) Then Stop
Open infile For Input As #1
For a = 1 To lines
'if lines is not passes in parameter
'still need to stop some how
If EOF(1) Then: Exit For
Line Input #1, Data
'the better the matc the better the parser
If Data Like "*OWNER:*" Then
ownerfound = 1
departmentsfound = -1
groupfound = -1
If test Then Debug.Print "owner found at line " & a
'put owner info on newline
current = current + 1
insert Data, current, owner, departments, group, last
'looking for owner departments or groups
End If
If Data Like "*DEPARTMENTS:*" And ownerfound = 1 Then
ownerfound = 2
departmentsfound = a
groupfound = -1
If test Then Debug.Print "departments found at line " & a
'put departments in department columns
insert Data, current, departments, group, last, void
'looking for blank, group,owner
End If
If Data Like "*GROUP :*" And ownerfound > 0 Then
ownerfound = 0
groupfound = a
departmentsfound = -1
If test Then Debug.Print "group found at line " & a
'put group in group columns
insert Data, current, group, last, void, void
'looking for blank, owner
End If
If Data Like " *" And a = departmentsfound + 1 Then
departmentfound = a
If test Then Debug.Print "department blank found at line "; a
'put departments info into departments columns
insert Data, current, departments, group, last, void
'lookin for blank group,owner
End If
If Data Like " *" And a = groupfound + 1 Then
groupfound = a
If test Then Debug.Print "group blank found at line "; a
'put group info into group columns
insert Data, current, group, last, void, void
'lookin for blank group,owner
End If
'test only
If test Then Debug.Print "(" & a & ") " & vbTab & Data
Next a
If Not EOF(1) Then complete = "you have not parsed all the lines in this file"
Close #1
MsgBox complete & vbLf & vbLf & "Time taken " & Format(Now() - t1, "hh:mm:ss")
End Sub
Sub insert(ByVal Data As String, ByRef c As Long, ByRef L As Long, ByRef U As Long, ByRef V As Long, ByRef W As Long)
'all boundaries affected by the insertion of a column must be mentioned in the call
'remove data identifiers the match must be perfect
'note the space before the colon in group
Data = Replace(Data, "OWNER:", "")
Data = Replace(Data, "DEPARTMENTS:", "")
Data = Replace(Data, "GROUP :", "")
'get rid of extra spaces in data
Data = wring(Data)
'data has now been cleaned
'force reference cell top left
Range("a1").Select
'where L is the lower boundary
'and U is the upper boundary
'if data="" then exit sub
If Data = "" Then Exit Sub
'If L.address = U.address Then 'insert_column_at U
If L = U Then
new_column U
'U has moved 1 to the right
U = U + 1
V = V + 1
W = W + 1
End If
'force reference point
Range("a1").Select
'if contents of L not empty then insert d,L.address+1,U
If Selection(c, L).Value > "" Then
insert Data, c, L + 1, U, V, W
Exit Sub
End If
Range("a1").Select
'l.value=head(data)
If InStr(Data, " ") > 0 Then
Selection(c, L).Value = Left$(Data, InStr(Data, " ") - 1)
Else
Selection(c, L).Value = Data
End If
'insert tail(data),L.address+1,U
If InStr(Data, " ") = 0 Then Data = ""
insert Mid$(Data, InStr(Data, " ") + 1), c, L + 1, U, V, W
End Sub
Sub new_column(col)
'this reads the column header of the previous column and increments the number portion
'the name is anything(underscore)number
'only that format will work
'force start position
Range("a1").Select
'the header before
Selection(1, col - 1).Select
s = letter_from_address(Selection.Address)
n = Selection.Value
ntype = Left$(n, InStr(n, "_"))
nvalue = Val(Mid$(n, Len(ntype) + 1, 255)) + 1
'the column we want to change
Selection(1, 2).Select
Selection.EntireColumn.insert , CopyOrigin:=xlFormatFromLeftOrAbove
s = letter_from_address(Selection.Address)
'select the new column's header
Range(s & "1").Select
'write the new incremented name
Selection = ntype & nvalue
End Sub
Function letter_from_address(a) As String
s = Mid$(a, 2)
letter_from_address = Left$(s, InStr(s, "$") - 1)
End Function
Function wring(s As String) As String
'remove all double spaces
s1 = s & " "
While Len(s1) > Len(s)
s1 = s
s = Replace(s, " ", " ")
Wend
'head and tail the string
wring = Trim(s)
End Function
Last edited by incidentals; Dec 29th, 2011 at 05:02 AM.
[RESOLVED] Convert text document into excel sheet
Reply With Quote
