[RESOLVED] Convert text document into excel sheet

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

thats very confusing

can you put a piece of your text up as an attachment
so that we can see exactly what it looks like
the formatting of what you have written is strange

are the @s separators or part og the group identifiers or what

here to talk

thanks for your response

Here i attached the text document
capture everything including @
all in columne vise
owner department group

so you only want...

Code:

---

OWNER:  Robert, zing
DEPARTMENTS:  @RXUJBRO  @RXUJSCH  XUJ      XUJAL
              XUJFIRE  XUJSC
CKT OS/390 ENVIRONMENTS:
-----------------------------------
 ACCTNUM : %%XUJ*    XUJ*

 DATASET : XUJTOPR  XUJTOTS
 FIREID :  XUJ1EMR  XUJ1FIR  XUJ2EMR
 GROUP :  @DXUJ*    @RXUJBRO  @RXUJCAA  @RXUJCAB
          @RXUJCHF  @RXUJCLR  @RXUJDEV  @RXUJEFT
          @RXUJHLA  @RXUJHLB  @RXUJHSS  @RXUJIIE
          @RXUJMTA  @RXUJMTB  @RXUJNCT  @RXUJOPS
          @RXUJPAS  @RXUJPCT  @RXUJSCH  @RXUJSTR
          @RXUJTPS  @RXUJTST  @RXUJVEF  @RXUJWPA
          @RXUJWPB  @RXUJZVM  @RXUJZYB  XUJFIRE SURROGAT :XUJ*****

 MKS OS/390 ENVIRONMENTS:
-----------------------------------
 ACCTNUM : %%XUJ*    XUJ*

 DATASET : XUJTOPR  XUJTOTS
 FIREID :  XUJ1EMR  XUJ1FIR
 GROUP :  @DXUJ*    @RXUJBRO  @RXUJCAA  @RXUJCHF
          @RXUJDEV  @RXUJDGR  @RXUJDRU  @RXUJEFT
          @RXUJHLA  @RXUJHLB  @RXUJHSS  @RXUJMTA
          @RXUJMTB  @RXUJOPS  @RXUJPAS  @RXUJPCT
          @RXUJSCH  @RXUJTPS  @RXUJTST  @RXUJVEF
          @RXUJWPA  @RXUJWPB  @RXUJZVM  XUJFIRE

---

just the its in red?

how do you want the out put to look?

can you send a text/table version of what you need?

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

hi i have code here but it capture from the group

Kam

Indents would make your code easier to follow ...

Code:

---

    Case "GROUP"
        strTrimDetail = Trim(strOwnerDetail)
        NextSpace: instrSpaces = InStr(1, strTrimDetail, Chr(32))
        intLen = Len(strTrimDetail)
        If instrSpaces > 1 Then
            strBeforeVal = Selection.Value
            strMid = Trim(Mid(strTrimDetail, 1, instrSpaces))
            If strBeforeVal <> strMid Then
                Selection.Offset(0, 1).Select
                Selection.Value = strMid
            End If
            strTrimDetail = Trim(Mid(strTrimDetail, instrSpaces))
            GoTo NextSpace
        Else
            strOwnerDetail = strTrimDetail
            Selection.Offset(0, 1).Select
            Selection.Value = strOwnerDetail
        End If
    Case Else
        GoTo NextRecord
End Select
intCount = intCount + 1
If intCount > 4 Then
    intCount = intCount - 1
End If
intCol = (-1) * intCount
NextRecord: Loop

---

Per your comment, you seem to be able
to capture the stuff in blue, but need to
also capture the stuff in red

Code:

---

DATASET : XUJTOPR  XUJTOTS
 FIREID :  XUJ1EMR  XUJ1FIR
GROUP :  @DXUJ*    @RXUJBRO  @RXUJCAA  @RXUJCHF
          @RXUJDEV  @RXUJDGR  @RXUJDRU  @RXUJEFT
          @RXUJHLA  @RXUJHLB  @RXUJHSS  @RXUJMTA
          @RXUJMTB  @RXUJOPS  @RXUJPAS  @RXUJPCT
          @RXUJSCH  @RXUJTPS  @RXUJTST  @RXUJVEF
          @RXUJWPA  @RXUJWPB  @RXUJZVM  XUJFIRE

---

Some questions:

1. What language are you using .. Excel VBA?
2. What are these statements?
   
   • GoTo NextSpace
   • GoTo NextRecord
   • NextRecord: Loop

Spoo

the following are the text document

your use of the select statement is a good start but you are not parsing everything you could..

the structure of the textfile is causing you some pain...

the solution is to remove the pain and produce an object that you can "cruise" through

so...

ok last 2 question before you get your answer -

(1) is the surrogate part of the owner infomation and so

(2) do you always have the two sections of group: to collect?

once answered i can generate a parse process for you to follow!

here to talk

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

owner:
department:
group:
not surrogate:
not surrogate:group:

is that correct?

first pass collection sub routine

Code:

---

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

---

part 2

data concatenation and cleansing

Code:

---

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

incidentals
thanks!. how do i transfer into excel .thanks a lot

Hi incendtals
her eis my code capture those information into excel. could you please help me where do i put

part 3

the code is output in record format

Code:

---

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

your code doe not allow for the first example you gave

he has 6 departments not 4

have you looked at my code yet?

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.

final part

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



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

but you test sample is very small

here to talk

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

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

---

now I will get back to the packing stuff

All done

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

(I would just comment out)

here to talk

the real answer is of course to collect the data intoa stream and create aset of parsing rules

that would let you collect just the bits required...


you would still need to look at padding and the header but it would be a completly different approch than the last solution.

you could of course like the multiple replacement of double spaces use an obsurd value for the number of names, departments and groups.

you would then simply fill a record up

and finally output the result using the maximum names, departmets and group indexes used in the record set.

or put the data directly onto the sheet and when all filled in reduce the sheet by deleting the columns that had only headings

NOW there a challenge

who's up for that one?

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

can you send the file you are using

the problem with the file was a control character left when the sample was sliced

its been removed and the file no longer thinks its shorter than actually is

for those interested
I am carrying on with kamakshi in the background as the data he wants to parse is a bit too important

I will let you see the results if its ok with him

is going fine the parser collects the appropriate lines

now i must just select the data elements and stuff them into a spreadsheet

here to talk

well here it is...

the parser works fine with his data

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

---