-
Extract to multiple text files
In C:\Sample I have over a thousand text files. Each text file contains multiple datasets that begins with the tag "<BTAG>" followed by a unique control ID and ends with the tag "<CTAG>" followed by the same unique control ID.
Is there a way to extract each of these datasets to a separate text file with the unique control ID as filename?
Sample file: Sample.txt
<BTAG> 111111
<1TAG> This is the first field
<2TAG> This is the second field
<3TAG> This is the third field
<4TAG> This is the fourth field
<CTAG> 111111
<BTAG> 222222
<1TAG> This is the first field
<2TAG> This is the second field
<CTAG> 222222
<BTAG> 333333
<1TAG> This is the first field
<2TAG> This is the second field
<1TAG> This is the third field
<2TAG> This is the fourth field
<1TAG> This is the fifth field
<2TAG> This is the sixth field
<CTAG> 333333
Desired output:
Filename 111111.txt
<BTAG> 111111
<1TAG> This is the first field
<2TAG> This is the second field
<3TAG> This is the third field
<4TAG> This is the fourth field
<CTAG> 111111
Filename 222222.txt
<BTAG> 222222
<1TAG> This is the first field
<2TAG> This is the second field
<CTAG> 222222
Filename 333333.txt
<BTAG> 333333
<1TAG> This is the first field
<2TAG> This is the second field
<1TAG> This is the third field
<2TAG> This is the fourth field
<1TAG> This is the fifth field
<2TAG> This is the sixth field
<CTAG> 333333
-
Put this in a workbook in the same folder as your text files.
[VBA]
Option Explicit
Sub SplitText()
Dim tName As String
Dim fName As String
Dim Pth As String
Dim fs, f, a
Dim txt As String
Dim i As Long
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Pth = ActiveWorkbook.Path & "\"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(Pth & "sample.txt", ForReading)
txt = f.readall
f.Close
Set f = Nothing
a = Split(txt, "<BTAG>")
For i = 1 To UBound(a)
fName = Trim(Split(a(i), "<")(0))
fName = Left(fName, Len(fName) - 2) & ".txt"
Set f = fs.CreateTextFile(Pth & fName, True)
f.write "<BTAG>" & a(i)
f.Close
Next
Set f = Nothing
Set fs = Nothing
End Sub
[/VBA]
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
-
-
Different approach!
Here's one more way of doing it. Of course, it is clumsy behemoth if you compare it with mdmackillop's code (Really good ).
Only thing different:
1. This file can be kept at any location and
2. The text file can also have anyname!
I'm attaching the file in which I played around!
Here is the code:
[VBA]Private Sub ImportFile_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim FileName As String
FileName = ThisWorkbook.Name
Dim Counter As Long
Dim FileLoc As Long
Dim SheetName As String
Dim CurRow As Long
Dim SavePath As String
Dim FileSaveName As String
Dim SaveName As String
SavePath = ActiveWorkbook.Path & "\"
'This opens selected 'Text' file in specified 'Excel' format
GetOpenFile = Application.GetOpenFilename
Workbooks.OpenText FileName:= _
GetOpenFile, Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlNone, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, _
Other:=False, OtherChar:=":", FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
ActiveSheet.Columns("A:A").EntireColumn.AutoFit
ActiveSheet.Range("A65536").FormulaR1C1 = "=COUNTIF(R[-65535]C:R[-1]C,""*BTAG*"")"
Counter = ActiveSheet.Range("A65536").Value
'This copies and saves data in the file containing program.
ActiveSheet.Select
FileLoc = Workbooks(FileName).Sheets.Count
ActiveSheet.Copy After:=Workbooks(FileName).Sheets(FileLoc)
SheetNo = ActiveWorkbook.Sheets.Count
Worksheets(SheetNo).Select
SheetName = Workbooks(FileName).Sheets(SheetNo).Name
'To close the imported sheet
Windows(SheetName).Activate
ActiveWindow.Close
With Sheets(SheetName)
CurRow = 1
For j = 1 To Counter
.Cells(CurRow, 2).FormulaR1C1 = "=RIGHT(RC[-1],(LEN(RC[-1])-FIND("" "",RC[-1],1)))"
SaveName = .Cells(CurRow, 2).Value & ".txt"
FileSaveName = SavePath & SaveName
For i = CurRow To .Cells(CurRow, 1).End(xlDown).Row
iFileNum = FreeFile 'get file number
Open FileSaveName For Append As #iFileNum
Print #iFileNum, .Cells(i, 1).Value 'add line to text file '
Close #iFileNum 'close file
Next i
CurRow = .Cells(CurRow, 1).End(xlDown).Row + 2
Next j
End With
Sheets(SheetName).Delete
MsgBox "Files are generated in Folder :" & SavePath
End Sub
[/VBA]
Regards,
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules