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]

great work !

Here's one more way of doing it. Of course, it is clumsy behemoth if you compare it with mdmackillop's code (Really good :bow: ).

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,