PDA

View Full Version : [SOLVED] Split text file by criteria



YasserKhalil
06-16-2017, 04:08 AM
Hello everyone
I have text file which I need to split by the space line to multiple text files and rename each text file with the first line
Attached sample for example the first text file will be renamed 1 and the second section will be exported to another text file and renamed "Sample" and so on
Thanks advanced for help

YasserKhalil
06-16-2017, 04:35 AM
I found this code that splits the text file into multiple text files but relying on specific number of lines .. and I couldn't adapt it to suit my request


Sub SplitTextFile()
Dim sFile As String
Dim sText As String
Dim lStep As Long
Dim vX As Variant
Dim vY As Variant
Dim iFile As Integer
Dim lCount As Long
Dim lIncr As Long
Dim lMax As Long
Dim lNb As Long
Dim lSoFar As Long


On Error GoTo ErrorHandle


sFile = Application.GetOpenFilename()
If sFile = "False" Then Exit Sub
lStep = Application.InputBox("Max Number Of Lines/Rows?", Type:=1)


lStep = lStep - 1
sText = CreateObject("Scripting.FileSystemObject").OpenTextFile(sFile).ReadAll
vX = Split(sText, vbLf)
sText = ""


Do While lSoFar < UBound(vX)
If UBound(vX) - lSoFar >= lStep Then
ReDim vY(lStep)
lMax = lStep + lSoFar
Else
ReDim vY(UBound(vX) - lSoFar)
lMax = UBound(vX)
End If


lNb = 0

For lCount = lSoFar To lMax
vY(lNb) = vX(lCount)
lNb = lNb + 1
Next lCount


lSoFar = lCount
iFile = FreeFile
lIncr = lIncr + 1
Open sFile & "-" & lIncr & ".txt" For Output As #iFile
Print #iFile, Join$(vY, vbCrLf)
Close #iFile
Loop


Erase vX
Erase vY


Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure SplitTextFile"
End Sub

YasserKhalil
06-16-2017, 06:27 AM
Any help in this topic please
How can I adapt the code attached in Post # 2 to fit my request

mdmackillop
06-16-2017, 07:11 AM
Takes a few seconds to run. I'm sure there is a better way.

Sub Test()
Dim sh1 As Worksheet, sh2 As Worksheet, myarea
Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTF = objFSO.OpenTextFile("C:\VBAX\sample.txt", 1)
strIn = objTF.readall
X = Split(strIn, vbNewLine)
[A1].Resize(UBound(X) + 1, 1) = Application.Transpose(X)
objTF.Close

Set sh1 = Sheets("Sheet1")
For Each cel In ActiveSheet.UsedRange.Cells
If cel = Chr(32) Then cel.Clear
Next cel
Application.DisplayAlerts = False
For Each myarea In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).Areas
Set sh = Sheets.Add
myarea.Copy sh.Cells(1, 1)
sh.Copy
ActiveWorkbook.SaveAs Filename:="C:\VBAX\" & sh.Cells(1, 1) & ".txt", FileFormat:=xlText
ActiveWorkbook.Close False
sh.Delete
Next myarea
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub

YasserKhalil
06-16-2017, 09:13 AM
That's wonderful and great. The only problem is that it takes some time
If it is possible to make it faster, this will be great as I have similar text files on which I will work on
Thank you very much

mdmackillop
06-16-2017, 10:06 AM
Option Explicit
Sub Test()
Dim fso As Object
Dim oFile As Object
Dim objTF As Object
Dim X, Y, I As Long
Dim strIn As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set objTF = fso.OpenTextFile("C:\VBAX\sample.txt", 1)
strIn = objTF.readall
X = Split(strIn, " " & vbNewLine & " " & vbNewLine)
For I = 0 To UBound(X) - 1
Y = Trim(Split(X(I), vbNewLine)(0))
Set oFile = fso.CreateTextFile("C:\VBAX\" & Y & ".txt")
oFile.Write X(I)
oFile.Close
Next I
End Sub

YasserKhalil
06-16-2017, 11:50 AM
Yes that is amazing and fascinating
Thank you very very much for great and wonderful help
Best and kind regards

mdmackillop
06-16-2017, 11:58 AM
Watch this line if using with other text files. I had to look at the text file content in Word to see the paragraph marks and "extra" spaces.

X = Split(strIn, " " & vbNewLine & " " & vbNewLine)

YasserKhalil
06-16-2017, 01:12 PM
Thanks a lot
The other text files are the same structure so the code works perfectly with them
Thank you very much for this magic solution